diff --git a/compiler/Bytecodes.h b/compiler/Bytecodes.h --- a/compiler/Bytecodes.h +++ b/compiler/Bytecodes.h @@ -34,6 +34,7 @@ #define bci_PUSH16_W 9 #define bci_PUSH32_W 10 #define bci_PUSH_G 11 +#define bci_PUSH_ALTS 12 #define bci_PUSH_ALTS_P 13 #define bci_PUSH_ALTS_N 14 #define bci_PUSH_ALTS_F 15 @@ -80,6 +81,7 @@ #define bci_CCALL 56 #define bci_SWIZZLE 57 #define bci_ENTER 58 +#define bci_RETURN 59 #define bci_RETURN_P 60 #define bci_RETURN_N 61 #define bci_RETURN_F 62 diff --git a/compiler/ClosureTypes.h b/compiler/ClosureTypes.h --- a/compiler/ClosureTypes.h +++ b/compiler/ClosureTypes.h @@ -87,4 +87,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA 63 -#define N_CLOSURE_TYPES 64 +#define CONTINUATION 64 +#define N_CLOSURE_TYPES 65 diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h --- a/compiler/CodeGen.Platform.h +++ b/compiler/CodeGen.Platform.h @@ -377,6 +377,74 @@ # define ft10 62 # define ft11 63 +#elif defined(MACHREGS_loongarch64) + +# define zero 0 +# define ra 1 +# define tp 2 +# define sp 3 +# define a0 4 +# define a1 5 +# define a2 6 +# define a3 7 +# define a4 8 +# define a5 9 +# define a6 10 +# define a7 11 +# define t0 12 +# define t1 13 +# define t2 14 +# define t3 15 +# define t4 16 +# define t5 17 +# define t6 18 +# define t7 19 +# define t8 20 +# define u0 21 +# define fp 22 +# define s0 23 +# define s1 24 +# define s2 25 +# define s3 26 +# define s4 27 +# define s5 28 +# define s6 29 +# define s7 30 +# define s8 31 + +# define fa0 32 +# define fa1 33 +# define fa2 34 +# define fa3 35 +# define fa4 36 +# define fa5 37 +# define fa6 38 +# define fa7 39 +# define ft0 40 +# define ft1 41 +# define ft2 42 +# define ft3 43 +# define ft4 44 +# define ft5 45 +# define ft6 46 +# define ft7 47 +# define ft8 48 +# define ft9 49 +# define ft10 50 +# define ft11 51 +# define ft12 52 +# define ft13 53 +# define ft14 54 +# define ft15 55 +# define fs0 56 +# define fs1 57 +# define fs2 58 +# define fs3 59 +# define fs4 60 +# define fs5 61 +# define fs6 62 +# define fs7 63 + #endif callerSaves :: GlobalReg -> Bool @@ -664,7 +732,10 @@ #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_powerpc) \ || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \ - || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) + || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \ + || defined(MACHREGS_wasm32) \ + || defined(MACHREGS_loongarch64) + # if defined(REG_Base) globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -50,7 +50,7 @@ This is accomplished through a combination of mechanisms: 1. When parsing source code, the RdrName-decorated AST has some - RdrNames which are Exact. These are wired-in RdrNames where the + RdrNames which are Exact. These are wired-in RdrNames where we could directly tell from the parsed syntax what Name to use. For example, when we parse a [] in a type we can just insert an Exact RdrName Name with the listTyConKey. @@ -119,7 +119,6 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Builtin.Names ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience @@ -136,7 +135,6 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique @@ -144,7 +142,11 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Data.FastString +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf +import Language.Haskell.Syntax.Module.Name + {- ************************************************************************ * * @@ -153,10 +155,14 @@ ************************************************************************ -} -allNameStrings :: [String] +allNameStrings :: Infinite String -- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] +allNameStrings = Inf.allListsOf ['a'..'z'] +allNameStringList :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStringList = Inf.toList allNameStrings + {- ************************************************************************ * * @@ -257,6 +263,7 @@ starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, + constraintKindRepName, -- WithDict withDictClassName, @@ -318,7 +325,6 @@ newStablePtrName, -- GHC Extensions - groupWithName, considerAccessibleName, -- Strings and lists @@ -333,6 +339,9 @@ fromListNName, toListName, + -- Non-empty lists + nonEmptyTyConName, + -- Overloaded record dot, record update getFieldName, setFieldName, @@ -341,7 +350,7 @@ zipName, foldrName, buildName, augmentName, appendName, -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, + stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, @@ -427,7 +436,7 @@ rationalToDoubleName, -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, + monadPlusClassName, -- Type-level naturals knownNatClassName, knownSymbolClassName, knownCharClassName, @@ -532,13 +541,13 @@ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION, +gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT, gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT, - gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING, + gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_LIST, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, @@ -548,11 +557,10 @@ aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST, cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL, gHC_TYPENATS, gHC_TYPENATS_INTERNAL, - dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module + dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic") -gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception") gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_MAGIC_DICT = mkPrimModule (fsLit "GHC.Magic.Dict") @@ -573,8 +581,8 @@ gHC_NUM_BIGNAT = mkBignumModule (fsLit "GHC.Num.BigNat") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +gHC_TUPLE_PRIM = mkPrimModule (fsLit "GHC.Tuple.Prim") dATA_EITHER = mkBaseModule (fsLit "Data.Either") -dATA_VOID = mkBaseModule (fsLit "Data.Void") dATA_LIST = mkBaseModule (fsLit "Data.List") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") @@ -618,6 +626,7 @@ dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") uNSAFE_COERCE = mkBaseModule (fsLit "Unsafe.Coerce") +fOREIGN_C_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr") gHC_SRCLOC :: Module gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") @@ -954,7 +963,7 @@ rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey voidTyConName :: Name -voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey +voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName, @@ -1113,8 +1122,7 @@ -- Functions for GHC extensions -groupWithName, considerAccessibleName :: Name -groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey +considerAccessibleName :: Name considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey -- Random GHC.Base functions @@ -1402,15 +1410,20 @@ trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey -- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name -starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey -starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey -starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +starKindRepName, starArrStarKindRepName, + starArrStarArrStarKindRepName, constraintKindRepName :: Name +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey -- WithDict withDictClassName :: Name -withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey +withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey +nonEmptyTyConName :: Name +nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey + -- Custom type errors errorMessageTypeErrorFamName , typeErrorTextDataConName @@ -1576,11 +1589,8 @@ toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey -- Other classes, needed for type defaulting -monadPlusClassName, randomClassName, randomGenClassName, - isStringClassName :: Name +monadPlusClassName, isStringClassName :: Name monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals @@ -1655,6 +1665,10 @@ fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +constPtrConName :: Name +constPtrConName = + tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey + {- ************************************************************************ * * @@ -1787,7 +1801,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, - doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, @@ -1798,7 +1812,8 @@ ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, - stringTyConKey :: Unique + stringTyConKey, + ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -1810,7 +1825,7 @@ doubleTyConKey = mkPreludeTyConUnique 10 floatPrimTyConKey = mkPreludeTyConUnique 11 floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 +fUNTyConKey = mkPreludeTyConUnique 13 intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8PrimTyConKey = mkPreludeTyConUnique 16 @@ -1841,6 +1856,10 @@ eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 +ctArrowTyConKey = mkPreludeTyConUnique 42 +ccArrowTyConKey = mkPreludeTyConUnique 43 +tcArrowTyConKey = mkPreludeTyConUnique 44 + statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, @@ -1850,7 +1869,8 @@ typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, - compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique + compactPrimTyConKey, stackSnapshotPrimTyConKey, + promptTagPrimTyConKey, constPtrTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 @@ -1879,6 +1899,7 @@ tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80 stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 +promptTagPrimTyConKey = mkPreludeTyConUnique 82 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 @@ -1889,16 +1910,21 @@ nonEmptyTyConKey :: Unique nonEmptyTyConKey = mkPreludeTyConUnique 86 +dictTyConKey :: Unique +dictTyConKey = mkPreludeTyConUnique 87 + -- Kind constructors liftedTypeKindTyConKey, unliftedTypeKindTyConKey, - tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey, + tYPETyConKey, cONSTRAINTTyConKey, + liftedRepTyConKey, unliftedRepTyConKey, constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey, zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -tYPETyConKey = mkPreludeTyConUnique 90 -constraintKindTyConKey = mkPreludeTyConUnique 92 +tYPETyConKey = mkPreludeTyConUnique 91 +cONSTRAINTTyConKey = mkPreludeTyConUnique 92 +constraintKindTyConKey = mkPreludeTyConUnique 93 levityTyConKey = mkPreludeTyConUnique 94 runtimeRepTyConKey = mkPreludeTyConUnique 95 vecCountTyConKey = mkPreludeTyConUnique 96 @@ -1920,7 +1946,6 @@ kindRepTyConKey = mkPreludeTyConUnique 107 typeLitSortTyConKey = mkPreludeTyConUnique 108 - -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, @@ -2056,6 +2081,7 @@ typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 +constPtrTyConKey = mkPreludeTyConUnique 417 {- ************************************************************************ @@ -2069,8 +2095,7 @@ floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, word8DataConKey, ioDataConKey, heqDataConKey, - coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey, - nonEmptyDataConKey :: Unique + eqDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 @@ -2089,7 +2114,6 @@ wordDataConKey = mkPreludeDataConUnique 15 ioDataConKey = mkPreludeDataConUnique 16 heqDataConKey = mkPreludeDataConUnique 18 -nonEmptyDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique @@ -2107,7 +2131,10 @@ ordEQDataConKey = mkPreludeDataConUnique 28 ordGTDataConKey = mkPreludeDataConUnique 29 +mkDictDataConKey :: Unique +mkDictDataConKey = mkPreludeDataConUnique 30 +coercibleDataConKey :: Unique coercibleDataConKey = mkPreludeDataConUnique 32 staticPtrDataConKey :: Unique @@ -2251,52 +2278,51 @@ ************************************************************************ -} -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, +wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, buildIdKey, foldrIdKey, recSelErrorIdKey, seqIdKey, eqStringIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, + impossibleErrorIdKey, impossibleConstraintErrorIdKey, + patErrorIdKey, voidPrimIdKey, realWorldPrimIdKey, recConErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, - absentSumFieldErrorIdKey, cstringLengthIdKey, - raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey + absentSumFieldErrorIdKey, cstringLengthIdKey :: Unique -wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] -absentErrorIdKey = mkPreludeMiscIdUnique 1 -augmentIdKey = mkPreludeMiscIdUnique 2 -appendIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -foldrIdKey = mkPreludeMiscIdUnique 6 -recSelErrorIdKey = mkPreludeMiscIdUnique 7 -seqIdKey = mkPreludeMiscIdUnique 8 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 -eqStringIdKey = mkPreludeMiscIdUnique 10 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 -runtimeErrorIdKey = mkPreludeMiscIdUnique 13 -patErrorIdKey = mkPreludeMiscIdUnique 14 -realWorldPrimIdKey = mkPreludeMiscIdUnique 15 -recConErrorIdKey = mkPreludeMiscIdUnique 16 +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +absentConstraintErrorIdKey = mkPreludeMiscIdUnique 2 +augmentIdKey = mkPreludeMiscIdUnique 3 +appendIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +impossibleErrorIdKey = mkPreludeMiscIdUnique 13 +impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14 +patErrorIdKey = mkPreludeMiscIdUnique 15 +realWorldPrimIdKey = mkPreludeMiscIdUnique 16 +recConErrorIdKey = mkPreludeMiscIdUnique 17 -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 -unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 18 -unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18 +unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20 -unpackCStringIdKey = mkPreludeMiscIdUnique 20 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 21 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 22 +unpackCStringIdKey = mkPreludeMiscIdUnique 21 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23 -voidPrimIdKey = mkPreludeMiscIdUnique 23 -typeErrorIdKey = mkPreludeMiscIdUnique 24 -divIntIdKey = mkPreludeMiscIdUnique 25 -modIntIdKey = mkPreludeMiscIdUnique 26 -cstringLengthIdKey = mkPreludeMiscIdUnique 27 -raiseOverflowIdKey = mkPreludeMiscIdUnique 28 -raiseUnderflowIdKey = mkPreludeMiscIdUnique 29 -raiseDivZeroIdKey = mkPreludeMiscIdUnique 30 +voidPrimIdKey = mkPreludeMiscIdUnique 24 +typeErrorIdKey = mkPreludeMiscIdUnique 25 +divIntIdKey = mkPreludeMiscIdUnique 26 +modIntIdKey = mkPreludeMiscIdUnique 27 +cstringLengthIdKey = mkPreludeMiscIdUnique 28 concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, @@ -2333,17 +2359,20 @@ traceKey :: Unique traceKey = mkPreludeMiscIdUnique 108 -inlineIdKey, noinlineIdKey :: Unique +nospecIdKey :: Unique +nospecIdKey = mkPreludeMiscIdUnique 109 + +inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique inlineIdKey = mkPreludeMiscIdUnique 120 -- see below -mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique +mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique mapIdKey = mkPreludeMiscIdUnique 121 -groupWithIdKey = mkPreludeMiscIdUnique 122 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 @@ -2483,14 +2512,15 @@ trLiftedRepKey = mkPreludeMiscIdUnique 516 -- KindReps for common cases -starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique -starKindRepKey = mkPreludeMiscIdUnique 520 -starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 +constraintKindRepKey = mkPreludeMiscIdUnique 523 -- Dynamic toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 523 +toDynIdKey = mkPreludeMiscIdUnique 530 bitIntegerIdKey :: Unique @@ -2784,8 +2814,10 @@ [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey , liftedDataConKey, unliftedDataConKey , tYPETyConKey + , cONSTRAINTTyConKey , runtimeRepTyConKey, boxedRepDataConKey , eqTyConKey + , listTyConKey , oneDataConKey , manyDataConKey - , funTyConKey ] + , fUNTyConKey, unrestrictedFunTyConKey ] diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -5,19 +5,21 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module GHC.Builtin.PrimOps ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, primOpResultType, primOpTag, maxPrimOpTag, primOpOcc, primOpWrapperId, + pprPrimOp, tagToEnumKey, primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsReallyInline, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -325,8 +327,8 @@ never throw an exception, so we cannot rewrite to a call to error. It is important that a non-checking primop never be transformed in a way that - would cause it to bottom. Doing so would violate Core's let/app invariant - (see Note [Core let/app invariant] in GHC.Core) which is critical to + would cause it to bottom. Doing so would violate Core's let-can-float invariant + (see Note [Core let-can-float invariant] in GHC.Core) which is critical to the simplifier's ability to float without fear of changing program meaning. @@ -479,7 +481,7 @@ * The "no-float-out" thing is achieved by ensuring that we never let-bind a can_fail or has_side_effects primop. The RHS of a let-binding (which can float in and out freely) satisfies - exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation; this is the let-can-float invariant. And exprOkForSpeculation is false of can_fail and has_side_effects. * So can_fail and has_side_effects primops will appear only as the @@ -658,7 +660,7 @@ GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed? Note that these wrappers aren't *quite* as expressive as their unwrapped -breathren, in that they may exhibit less representation polymorphism. +brethren, in that they may exhibit less representation polymorphism. For instance, consider the case of mkWeakNoFinalizer#, which has type: mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type). @@ -788,8 +790,10 @@ -- Output stuff: -pprPrimOp :: PrimOp -> SDoc +pprPrimOp :: IsLine doc => PrimOp -> doc pprPrimOp other_op = pprOccName (primOpOcc other_op) +{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-} +{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- ************************************************************************ @@ -804,3 +808,12 @@ instance Outputable PrimCall where ppr (PrimCall lbl pkgId) = text "__primcall" <+> ppr pkgId <+> ppr lbl + +-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it +-- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- hence induce thread/stack/heap changes. +primOpIsReallyInline :: PrimOp -> Bool +primOpIsReallyInline = \case + SeqOp -> False + DataToTagOp -> False + p -> not (primOpOutOfLine p) diff --git a/compiler/GHC/Builtin/PrimOps/Ids.hs b/compiler/GHC/Builtin/PrimOps/Ids.hs --- a/compiler/GHC/Builtin/PrimOps/Ids.hs +++ b/compiler/GHC/Builtin/PrimOps/Ids.hs @@ -9,7 +9,7 @@ -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules) -import GHC.Core.Type (mkForAllTys, mkVisFunTysMany) +import GHC.Core.Type (mkForAllTys, mkVisFunTysMany, argsHaveFixedRuntimeRep ) import GHC.Core.FVs (mkRuleInfo) import GHC.Builtin.PrimOps @@ -38,7 +38,8 @@ name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info + id = mkGlobalId (PrimOpId prim_op lev_poly) name ty info + lev_poly = not (argsHaveFixedRuntimeRep ty) -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr @@ -51,7 +52,6 @@ `setDmdSigInfo` strict_sig `setCprSigInfo` mkCprSig arity cpr `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't -- get silly warnings from Desugar.dsRule (the inline_shadows_rule -- test) about a RULE conflicting with a possible inlining diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -18,7 +18,7 @@ mkWiredInIdName, -- used in GHC.Types.Id.Make -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, + wiredInTyCons, isBuiltInOcc_maybe, isPunOcc_maybe, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, @@ -34,7 +34,7 @@ promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, -- * Boxing primitive types - boxingDataCon_maybe, + boxingDataCon, BoxingInfo(..), -- * Char charTyCon, charDataCon, charTyCon_RDR, @@ -63,10 +63,6 @@ promotedNilDataCon, promotedConsDataCon, mkListTy, mkPromotedListTy, - -- * NonEmpty - nonEmptyTyCon, nonEmptyTyConName, - nonEmptyDataCon, nonEmptyDataConName, - -- * Maybe maybeTyCon, maybeTyConName, nothingDataCon, nothingDataConName, promotedNothingDataCon, @@ -83,7 +79,7 @@ unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind, - filterCTuple, + filterCTuple, mkConstraintTupleTy, -- ** Constraint tuples cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, @@ -105,6 +101,8 @@ isLiftedTypeKindTyConName, typeToTypeKind, liftedRepTyCon, unliftedRepTyCon, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, @@ -116,15 +114,17 @@ coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, -- * RuntimeRep and friends - runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon, + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, boxedRepDataConTyCon, - runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, + runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + -- * Levity + levityTyCon, levityTy, liftedDataConTyCon, unliftedDataConTyCon, - liftedDataConTy, unliftedDataConTy, + liftedDataConTy, unliftedDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, @@ -170,26 +170,32 @@ import GHC.Builtin.Uniques -- others: +import GHC.Core( Expr(Type), mkConApp ) import GHC.Core.Coercion.Axiom -import GHC.Types.Id -import GHC.Types.TyThing -import GHC.Types.SourceText -import GHC.Types.Var (VarBndr (Bndr)) -import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import GHC.Unit.Module ( Module ) import GHC.Core.Type -import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) -import GHC.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 ) @@ -201,6 +207,7 @@ import qualified Data.ByteString.Char8 as BS +import Data.Foldable import Data.List ( elemIndex, intersperse ) alpha_tyvar :: [TyVar] @@ -273,7 +280,8 @@ -- See also Note [Known-key names] wiredInTyCons :: [TyCon] -wiredInTyCons = [ -- Units are not treated like other tuples, because they +wiredInTyCons = map (dataConTyCon . snd) boxingDataCons + ++ [ -- Units are not treated like other tuples, because they -- are defined in GHC.Base, and there's only a few of them. We -- put them in wiredInTyCons so that they will pre-populate -- the name cache, so the parser in isBuiltInOcc_maybe doesn't @@ -281,7 +289,7 @@ unitTyCon , unboxedUnitTyCon - -- Solo (i.e., the bosed 1-tuple) is also not treated + -- Solo (i.e., the boxed 1-tuple) is also not treated -- like other tuples (i.e. we /do/ include it here), -- since it does not use special syntax like other tuples -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names @@ -317,7 +325,6 @@ , unliftedRepTyCon , zeroBitRepTyCon , zeroBitTypeTyCon - , nonEmptyTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -372,14 +379,10 @@ trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") listTyConKey listTyCon 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 @@ -508,81 +511,7 @@ typeSymbolKindConName :: Name typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon -constraintKindTyConName :: Name -constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon -liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon -unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon -zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") zeroBitTypeTyConKey zeroBitTypeTyCon - -liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name -liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon -unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon -zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") zeroBitRepTyConKey zeroBitRepTyCon - -multiplicityTyConName :: Name -multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") - multiplicityTyConKey multiplicityTyCon - -oneDataConName, manyDataConName :: Name -oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon -manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon - -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name -runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon -vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon -tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon -sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon -boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon - -levityTyConName, liftedDataConName, unliftedDataConName :: Name -levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon -liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon -unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon - - --- See Note [Wiring in RuntimeRep] -runtimeRepSimpleDataConNames :: [Name] -runtimeRepSimpleDataConNames - = zipWith3Lazy mk_special_dc_name - [ fsLit "IntRep" - , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" - , fsLit "WordRep" - , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" - , fsLit "AddrRep" - , fsLit "FloatRep", fsLit "DoubleRep" - ] - runtimeRepSimpleDataConKeys - runtimeRepSimpleDataCons - -vecCountTyConName :: Name -vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon - --- See Note [Wiring in RuntimeRep] -vecCountDataConNames :: [Name] -vecCountDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" - , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] - vecCountDataConKeys - vecCountDataCons - -vecElemTyConName :: Name -vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon - --- See Note [Wiring in RuntimeRep] -vecElemDataConNames :: [Name] -vecElemDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" - , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" - , fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - vecElemDataConKeys - vecElemDataCons - -mk_special_dc_name :: FastString -> Unique -> DataCon -> Name -mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc - boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName @@ -608,7 +537,7 @@ pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon name cType tyvars cons = mkAlgTyCon name - (mkAnonTyConBinders VisArg tyvars) + (mkAnonTyConBinders tyvars) liftedTypeKind (map (const Representational) tyvars) cType @@ -618,24 +547,41 @@ False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs tys = pcDataConW n univs (map linear tys) - -pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon -pcDataConW n univs tys = pcDataConWithFixity False n univs +pcDataCon n univs tys + = pcDataConWithFixity False n univs [] -- no ex_tvs univs -- the univs are precisely the user-written tyvars - tys + [] -- No theta + (map linear tys) +pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon +-- Used for data constructors whose arguments are all constraints. +-- Notably constraint tuples, Eq# etc. +pcDataConConstraint n univs theta + = pcDataConWithFixity False n univs + [] -- No ex_tvs + univs -- The univs are precisely the user-written tyvars + theta -- All constraint arguments + [] -- No value arguments + +-- Used for RuntimeRep and friends; things with PromDataConInfo +pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name + (dataConWorkerUnique (nameUnique dc_name)) rri + [] [] [] [] (map linear arg_tys) tycon + pcDataConWithFixity :: Bool -- ^ declared infix? -> Name -- ^ datacon name -> [TyVar] -- ^ univ tyvars -> [TyCoVar] -- ^ ex tycovars -> [TyCoVar] -- ^ user-written tycovars + -> ThetaType -> [Scaled Type] -- ^ args -> TyCon -> DataCon -pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) - NoRRI +pcDataConWithFixity infx n = pcDataConWithFixity' infx n + (dataConWorkerUnique (nameUnique n)) NoPromInfo -- The Name's unique is the first of two free uniques; -- the first is used for the datacon itself, -- the second is used for the "worker name" @@ -643,9 +589,9 @@ -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. -pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo +pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo -> [TyVar] -> [TyCoVar] -> [TyCoVar] - -> [Scaled Type] -> TyCon -> DataCon + -> ThetaType -> [Scaled Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. -- @@ -657,7 +603,7 @@ -- to regret doing so (we do). pcDataConWithFixity' declared_infix dc_name wrk_key rri - tyvars ex_tyvars user_tyvars arg_tys tycon + tyvars ex_tyvars user_tyvars theta arg_tys tycon = data_con where tag_map = mkTyConTagMap tycon @@ -673,7 +619,7 @@ tyvars ex_tyvars (mkTyVarBinders SpecifiedSpec user_tyvars) [] -- No equality spec - [] -- No theta + theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) rri tycon @@ -699,16 +645,11 @@ dc_occ = nameOccName dc_name wrk_occ = mkDataConWorkerOcc dc_occ --- used for RuntimeRep and friends -pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon -pcSpecialDataCon dc_name arg_tys tycon rri - = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] [] (map linear arg_tys) tycon {- ************************************************************************ * * - Kinds + Symbol * * ************************************************************************ -} @@ -720,14 +661,7 @@ typeSymbolKind :: Kind typeSymbolKind = mkTyConTy typeSymbolKindCon -constraintKindTyCon :: TyCon --- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! -constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] -typeToTypeKind, constraintKind :: Kind -typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind -constraintKind = mkTyConTy constraintKindTyCon - {- ************************************************************************ * * @@ -808,7 +742,7 @@ Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: data () = () - data Solo a = Solo a + data Solo a = MkSolo a data (a,b) = (a,b) There is no way to write a boxed one-tuple in Haskell using tuple syntax. @@ -831,7 +765,7 @@ -- Wrinkle: Make boxed one-tuple names have known keys ----- -We make boxed one-tuple names have known keys so that `data Solo a = Solo a`, +We make boxed one-tuple names have known keys so that `data Solo a = MkSolo a`, defined in GHC.Tuple, will be used when one-tuples are spliced in through Template Haskell. This program (from #18097) crucially relies on this: @@ -867,7 +801,7 @@ ":" -> Just consDataConName -- function tycon - "FUN" -> Just funTyConName + "FUN" -> Just fUNTyConName "->" -> Just unrestrictedFunTyConName -- boxed tuple data/tycon @@ -925,22 +859,38 @@ = choose_ns (getName (tupleTyCon boxity arity)) (getName (tupleDataCon boxity arity)) +-- When resolving names produced by Template Haskell (see thOrigRdrName +-- in GHC.ThToHs), we want ghc-prim:GHC.Types.List to yield an Exact name, not +-- an Orig name. +-- +-- This matters for pretty-printing under ListTuplePuns. If we don't do it, +-- then -ddump-splices will print ''[] as ''GHC.Types.List. +-- +-- Test case: th/T13776 +-- +isPunOcc_maybe :: Module -> OccName -> Maybe Name +isPunOcc_maybe mod occ + | mod == gHC_TYPES, occ == occName listTyConName + = Just listTyConName +isPunOcc_maybe _ _ = Nothing + mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) +mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ns ar) mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) -mkTupleStr :: Boxity -> Arity -> String +mkTupleStr :: Boxity -> NameSpace -> Arity -> String mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = mkUnboxedTupleStr +mkTupleStr Unboxed = const mkUnboxedTupleStr -mkBoxedTupleStr :: Arity -> String -mkBoxedTupleStr 0 = "()" -mkBoxedTupleStr 1 = "Solo" -- See Note [One-tuples] -mkBoxedTupleStr ar = '(' : commas ar ++ ")" +mkBoxedTupleStr :: NameSpace -> Arity -> String +mkBoxedTupleStr _ 0 = "()" +mkBoxedTupleStr ns 1 | isDataConNameSpace ns = "MkSolo" -- See Note [One-tuples] +mkBoxedTupleStr _ 1 = "Solo" -- See Note [One-tuples] +mkBoxedTupleStr _ ar = '(' : commas ar ++ ")" mkUnboxedTupleStr :: Arity -> String mkUnboxedTupleStr 0 = "(##)" @@ -1088,12 +1038,11 @@ mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple Boxed arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con BoxedTuple flavour tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) tc_res_kind = liftedTypeKind - tc_arity = arity flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders @@ -1101,7 +1050,7 @@ tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon boxity = Boxed - modu = gHC_TUPLE + modu = gHC_TUPLE_PRIM tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq @@ -1111,7 +1060,7 @@ mk_tuple Unboxed arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con UnboxedTuple flavour -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon @@ -1120,8 +1069,6 @@ (\ks -> map mkTYPEapp ks) tc_res_kind = unboxedTupleKind rr_tys - - tc_arity = arity * 2 flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders @@ -1145,7 +1092,7 @@ (mkPrelTyConRepName tc_name) klass = mk_ctuple_class tycon sc_theta sc_sel_ids - tuple_con = pcDataConW dc_name tvs (map unrestricted sc_theta) tycon + tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon binders = mkTemplateAnonTyConBinders (replicate arity constraintKind) roles = replicate arity Nominal @@ -1203,7 +1150,6 @@ unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 - {- ********************************************************************* * * Unboxed sums @@ -1275,7 +1221,7 @@ mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) mk_sum arity = (tycon, sum_cons) where - tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons) UnboxedSumTyCon tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) @@ -1332,7 +1278,7 @@ rhs klass (mkPrelTyConRepName eqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint eqDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1350,7 +1296,7 @@ rhs klass (mkPrelTyConRepName heqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint heqDataConName tvs [sc_pred] tycon -- Kind: forall k1 k2. k1 -> k2 -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id @@ -1368,7 +1314,7 @@ rhs klass (mkPrelTyConRepName coercibleTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1402,12 +1348,20 @@ data Multiplicity = One | Many -} +multiplicityTyConName :: Name +multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") + multiplicityTyConKey multiplicityTyCon + +oneDataConName, manyDataConName :: Name +oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon +manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon + multiplicityTy :: Type multiplicityTy = mkTyConTy multiplicityTyCon multiplicityTyCon :: TyCon multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] - [oneDataCon, manyDataCon] + [oneDataCon, manyDataCon] oneDataCon, manyDataCon :: DataCon oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon @@ -1433,19 +1387,21 @@ where binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] -unrestrictedFunTy :: Type -unrestrictedFunTy = functionWithMultiplicity manyDataConTy - +------------------------ +-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> Type +-- type (->) = FUN 'Many unrestrictedFunTyCon :: TyCon -unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy - where arrowKind = mkTyConKind binders liftedTypeKind - -- See also funTyCon - binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) - , Bndr runtimeRep2TyVar (NamedTCB Inferred) - ] - ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty - , mkTYPEapp runtimeRep2Ty - ] +unrestrictedFunTyCon + = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] + (TyCoRep.TyConApp fUNTyCon [manyDataConTy]) + where + arrowKind = mkTyConKind binders liftedTypeKind + -- See also funTyCon + binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] + ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty + , mkTYPEapp runtimeRep2Ty ] unrestrictedFunTyConName :: Name unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") @@ -1456,91 +1412,94 @@ * * Type synonyms (all declared in ghc-prim:GHC.Types) - type Type = TYPE LiftedRep -- liftedTypeKind - type UnliftedType = TYPE UnliftedRep -- unliftedTypeKind - type LiftedRep = BoxedRep Lifted -- liftedRepTy - type UnliftedRep = BoxedRep Unlifted -- unliftedRepTy + type CONSTRAINT :: RuntimeRep -> Type -- primitive; cONSTRAINTKind + type Constraint = CONSTRAINT LiftedRep :: Type -- constraintKind + type TYPE :: RuntimeRep -> Type -- primitive; tYPEKind + type Type = TYPE LiftedRep :: Type -- liftedTypeKind + type UnliftedType = TYPE UnliftedRep :: Type -- unliftedTypeKind + + type LiftedRep = BoxedRep Lifted :: RuntimeRep -- liftedRepTy + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep -- unliftedRepTy + * * ********************************************************************* -} -- For these synonyms, see --- Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim, and +-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and -- Note [Using synonyms to compress types] in GHC.Core.Type +{- Note [Naked FunTy] +~~~~~~~~~~~~~~~~~~~~~ +GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument +flag and arg/res types. But when constructing the kinds of tYPETyCon and +cONSTRAINTTyCon we don't want to make these checks because + TYPE :: RuntimeRep -> Type +i.e. TYPE :: RuntimeRep -> TYPE LiftedRep + +so the check will loop infinitely. Hence the use of a naked FunTy +constructor in tTYPETyCon and cONSTRAINTTyCon. +-} + + ---------------------- --- @type Type = TYPE ('BoxedRep 'Lifted)@ +-- type Constraint = CONSTRAINT LiftedRep +constraintKindTyCon :: TyCon +constraintKindTyCon + = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy] + +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") + constraintKindTyConKey constraintKindTyCon + +constraintKind :: Kind +constraintKind = mkTyConTy constraintKindTyCon + +---------------------- +-- type Type = TYPE LiftedRep liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs where rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] -liftedTypeKind :: Type +liftedTypeKindTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") + liftedTypeKindTyConKey liftedTypeKindTyCon + +liftedTypeKind, typeToTypeKind :: Type liftedTypeKind = mkTyConTy liftedTypeKindTyCon +typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind ---------------------- --- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@ +-- type UnliftedType = TYPE ('BoxedRep 'Unlifted) unliftedTypeKindTyCon :: TyCon unliftedTypeKindTyCon = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs where rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] +unliftedTypeKindTyConName :: Name +unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") + unliftedTypeKindTyConKey unliftedTypeKindTyCon + unliftedTypeKind :: Type unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon ----------------------- --- @type ZeroBitType = TYPE ZeroBitRep -zeroBitTypeTyCon :: TyCon -zeroBitTypeTyCon - = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] -zeroBitTypeKind :: Type -zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon - ----------------------- --- | @type LiftedRep = 'BoxedRep 'Lifted@ -liftedRepTyCon :: TyCon -liftedRepTyCon - = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] - -liftedRepTy :: Type -liftedRepTy = mkTyConTy liftedRepTyCon - ----------------------- --- | @type UnliftedRep = 'BoxedRep 'Unlifted@ -unliftedRepTyCon :: TyCon -unliftedRepTyCon - = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] - -unliftedRepTy :: Type -unliftedRepTy = mkTyConTy unliftedRepTyCon - ----------------------- --- | @type ZeroBitRep = 'Tuple '[] -zeroBitRepTyCon :: TyCon -zeroBitRepTyCon - = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - -zeroBitRepTy :: Type -zeroBitRepTy = mkTyConTy zeroBitRepTyCon - - {- ********************************************************************* * * data Levity = Lifted | Unlifted * * ********************************************************************* -} +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] @@ -1549,9 +1508,9 @@ liftedDataCon, unliftedDataCon :: DataCon liftedDataCon = pcSpecialDataCon liftedDataConName - [] levityTyCon LiftedInfo + [] levityTyCon (Levity Lifted) unliftedDataCon = pcSpecialDataCon unliftedDataConName - [] levityTyCon UnliftedInfo + [] levityTyCon (Levity Unlifted) liftedDataConTyCon :: TyCon liftedDataConTyCon = promoteDataCon liftedDataCon @@ -1591,21 +1550,35 @@ runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + -- Here we list all the data constructors + -- of the RuntimeRep data type (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) + sumRepDataCon : boxedRepDataCon : + runtimeRepSimpleDataCons) runtimeRepTy :: Type runtimeRepTy = mkTyConTy runtimeRepTyCon +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon + +vecRepDataConName = mk_runtime_rep_dc_name (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mk_runtime_rep_dc_name (fsLit "SumRep") sumRepDataConKey sumRepDataCon +boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon + +mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name +mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc + boxedRepDataCon :: DataCon boxedRepDataCon = pcSpecialDataCon boxedRepDataConName [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [lev] - = case tyConRuntimeRepInfo (tyConAppTyCon lev) of - LiftedInfo -> [LiftedRep] - UnliftedInfo -> [UnliftedRep] + = case tyConPromDataConInfo (tyConAppTyCon lev) of + Levity Lifted -> [LiftedRep] + Levity Unlifted -> [UnliftedRep] _ -> pprPanic "boxedRepDataCon" (ppr lev) prim_rep_fun args = pprPanic "boxedRepDataCon" (ppr args) @@ -1614,23 +1587,6 @@ boxedRepDataConTyCon :: TyCon boxedRepDataConTyCon = promoteDataCon boxedRepDataCon -vecRepDataCon :: DataCon -vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon - , mkTyConTy vecElemTyCon ] - runtimeRepTyCon - (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType - prim_rep_fun [count, elem] - | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) - , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = [VecRep n e] - prim_rep_fun args - = pprPanic "vecRepDataCon" (ppr args) - -vecRepDataConTyCon :: TyCon -vecRepDataConTyCon = promoteDataCon vecRepDataCon - tupleRepDataCon :: DataCon tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) @@ -1653,7 +1609,7 @@ where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) + = map slotPrimRep (toList (ubxSumRepType prim_repss)) where rr_tys = extractPromotedList rr_ty_list doc = text "sumRepDataCon" <+> ppr rr_tys @@ -1668,18 +1624,27 @@ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType runtimeRepSimpleDataCons :: [DataCon] runtimeRepSimpleDataCons - = zipWithLazy mk_runtime_rep_dc - [ IntRep - , Int8Rep, Int16Rep, Int32Rep, Int64Rep - , WordRep - , Word8Rep, Word16Rep, Word32Rep, Word64Rep - , AddrRep - , FloatRep, DoubleRep - ] - runtimeRepSimpleDataConNames + = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys + [ (fsLit "IntRep", IntRep) + , (fsLit "Int8Rep", Int8Rep) + , (fsLit "Int16Rep", Int16Rep) + , (fsLit "Int32Rep", Int32Rep) + , (fsLit "Int64Rep", Int64Rep) + , (fsLit "WordRep", WordRep) + , (fsLit "Word8Rep", Word8Rep) + , (fsLit "Word16Rep", Word16Rep) + , (fsLit "Word32Rep", Word32Rep) + , (fsLit "Word64Rep", Word64Rep) + , (fsLit "AddrRep", AddrRep) + , (fsLit "FloatRep", FloatRep) + , (fsLit "DoubleRep", DoubleRep) ] where - mk_runtime_rep_dc primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon + mk_runtime_rep_dc uniq (fs, primrep) + = data_con + where + data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + dc_name = mk_runtime_rep_dc_name fs uniq data_con -- See Note [Wiring in RuntimeRep] intRepDataConTy, @@ -1687,7 +1652,7 @@ wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType [intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, @@ -1697,17 +1662,108 @@ ] = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons +---------------------- +-- | @type ZeroBitRep = 'Tuple '[] +zeroBitRepTyCon :: TyCon +zeroBitRepTyCon + = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + +zeroBitRepTyConName :: Name +zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") + zeroBitRepTyConKey zeroBitRepTyCon + +zeroBitRepTy :: RuntimeRepType +zeroBitRepTy = mkTyConTy zeroBitRepTyCon + +---------------------- +-- @type ZeroBitType = TYPE ZeroBitRep +zeroBitTypeTyCon :: TyCon +zeroBitTypeTyCon + = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] + +zeroBitTypeTyConName :: Name +zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") + zeroBitTypeTyConKey zeroBitTypeTyCon + +zeroBitTypeKind :: Type +zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon + +---------------------- +-- | @type LiftedRep = 'BoxedRep 'Lifted@ +liftedRepTyCon :: TyCon +liftedRepTyCon + = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] + +liftedRepTyConName :: Name +liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") + liftedRepTyConKey liftedRepTyCon + +liftedRepTy :: RuntimeRepType +liftedRepTy = mkTyConTy liftedRepTyCon + +---------------------- +-- | @type UnliftedRep = 'BoxedRep 'Unlifted@ +unliftedRepTyCon :: TyCon +unliftedRepTyCon + = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] + +unliftedRepTyConName :: Name +unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") + unliftedRepTyConKey unliftedRepTyCon + +unliftedRepTy :: RuntimeRepType +unliftedRepTy = mkTyConTy unliftedRepTyCon + + +{- ********************************************************************* +* * + VecCount, VecElem +* * +********************************************************************* -} + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [count, elem] + | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count) + , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem) + = [VecRep n e] + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + vecCountTyCon :: TyCon vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons -- See Note [Wiring in RuntimeRep] vecCountDataCons :: [DataCon] -vecCountDataCons = zipWithLazy mk_vec_count_dc - [ 2, 4, 8, 16, 32, 64 ] - vecCountDataConNames +vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys where - mk_vec_count_dc n name - = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + mk_vec_count_dc logN key = con + where + n = 2^(logN :: Int) + name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con + con = pcSpecialDataCon name [] vecCountTyCon (VecCount n) -- See Note [Wiring in RuntimeRep] vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, @@ -1720,14 +1776,19 @@ -- See Note [Wiring in RuntimeRep] vecElemDataCons :: [DataCon] -vecElemDataCons = zipWithLazy mk_vec_elem_dc - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConNames +vecElemDataCons = zipWith3 mk_vec_elem_dc + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep" + , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConKeys where - mk_vec_elem_dc elem name - = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + mk_vec_elem_dc nameFs elemRep key = con + where + name = mk_runtime_rep_dc_name nameFs key con + con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep) -- See Note [Wiring in RuntimeRep] int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, @@ -1746,30 +1807,6 @@ * * ********************************************************************* -} -boxingDataCon_maybe :: TyCon -> Maybe DataCon --- boxingDataCon_maybe Char# = C# --- boxingDataCon_maybe Int# = I# --- ... etc ... --- See Note [Boxing primitive types] -boxingDataCon_maybe tc - = lookupNameEnv boxing_constr_env (tyConName tc) - -boxing_constr_env :: NameEnv DataCon -boxing_constr_env - = mkNameEnv [(charPrimTyConName , charDataCon ) - ,(intPrimTyConName , intDataCon ) - ,(wordPrimTyConName , wordDataCon ) - ,(floatPrimTyConName , floatDataCon ) - ,(doublePrimTyConName, doubleDataCon) ] - -{- Note [Boxing primitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a handful of primitive types (Int, Char, Word, Float, Double), -we can readily box and an unboxed version (Int#, Char# etc) using -the corresponding data constructor. This is useful in a couple -of places, notably let-floating -} - - charTy :: Type charTy = mkTyConTy charTyCon @@ -1846,6 +1883,140 @@ doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon +{- ********************************************************************* +* * + Boxing data constructors +* * +********************************************************************* -} + +{- Note [Boxing constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep +that "box" unlifted values into a (boxed, lifted) value of kind Type. For example + + type Int8Box :: TYPE Int8Rep -> Type + data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a + -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a + +Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`. We can also +package up a (lifted) Constraint as a value of kind Type. + +There are a fixed number of RuntimeReps, so we only need a fixed number +of boxing types. (For TupleRep we need to box recursively; not yet done, +see #22336.) + +This is used: + +* In desugaring, when we need to package up a bunch of values into a tuple, + for example when desugaring arrows. See Note [Big tuples] in GHC.Core.Make. + +* In let-floating when we want to float an unlifted sub-expression. + See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels + +In this module we make wired-in data type declarations for all of +these boxing functions. The goal is to define boxingDataCon_maybe. + +Wrinkles +(W1) The runtime system has special treatment (e.g. commoning up during GC) + for Int and Char values. See Note [CHARLIKE and INTLIKE closures] and + Note [Precomputed static closures] in the RTS. + + So we treat Int# and Char# specially, in specialBoxingDataCon_maybe +-} + +data BoxingInfo b + = BI_NoBoxNeeded -- The type has kind Type, so there is nothing to do + + | BI_NoBoxAvailable -- The type does not have kind Type, but sadly we + -- don't have a boxing data constructor either + + | BI_Box -- The type does not have kind Type, and we do have a + -- boxing data constructor; here it is + { bi_data_con :: DataCon + , bi_inst_con :: Expr b + , bi_boxed_type :: Type } + -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int } + -- recall: data Int = I# Int# + -- + -- BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty + -- , bi_boxed_type = Int8Box ty }A + -- recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a + +boxingDataCon :: Type -> BoxingInfo b +-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that +-- will box it, and the type of the boxed thing, which /does/ now have kind Type. +-- See Note [Boxing constructors] +boxingDataCon ty + | tcIsLiftedTypeKind kind + = BI_NoBoxNeeded -- Fast path for Type + + | Just box_con <- specialBoxingDataCon_maybe ty + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [] + , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) } + + | Just box_con <- lookupTypeMap boxingDataConMap kind + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty] + , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] } + + | otherwise + = BI_NoBoxAvailable + + where + kind = typeKind ty + +specialBoxingDataCon_maybe :: Type -> Maybe DataCon +-- ^ See Note [Boxing constructors] wrinkle (W1) +specialBoxingDataCon_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, _) | tc `hasKey` intPrimTyConKey -> Just intDataCon + | tc `hasKey` charPrimTyConKey -> Just charDataCon + _ -> Nothing + +boxingDataConMap :: TypeMap DataCon +-- See Note [Boxing constructors] +boxingDataConMap = foldl add emptyTypeMap boxingDataCons + where + add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con + +boxingDataCons :: [(Kind, DataCon)] +-- The Kind is the kind of types for which the DataCon is the right boxing +boxingDataCons = zipWith mkBoxingDataCon + (map mkBoxingTyConUnique [1..]) + [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox") + , (mkTYPEapp intRepDataConTy, fsLit "IntBox", fsLit "MkIntBox") + + , (mkTYPEapp floatRepDataConTy, fsLit "FloatBox", fsLit "MkFloatBox") + , (mkTYPEapp doubleRepDataConTy, fsLit "DoubleBox", fsLit "MkDoubleBox") + + , (mkTYPEapp int8RepDataConTy, fsLit "Int8Box", fsLit "MkInt8Box") + , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box") + , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box") + , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box") + + , (mkTYPEapp word8RepDataConTy, fsLit "Word8Box", fsLit "MkWord8Box") + , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box", fsLit "MkWord16Box") + , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box", fsLit "MkWord32Box") + , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box", fsLit "MkWord64Box") + + , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox") + , (constraintKind, fsLit "DictBox", fsLit "MkDictBox") ] + +mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon) +mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc) + = (kind, dc) + where + uniq_dc = boxingDataConUnique uniq_tc + + (tv:_) = mkTemplateTyVars (repeat kind) + tc = pcTyCon tc_name Nothing [tv] [dc] + tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc + + dc | isConstraintKind kind + = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc + | otherwise + = pcDataCon dc_name [tv] [mkTyVarTy tv] tc + dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc + {- ************************************************************************ * * @@ -1952,23 +2123,14 @@ consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -} consDataConName - alpha_tyvar [] alpha_tyvar - (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon + alpha_tyvar [] alpha_tyvar [] + (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) + listTyCon + -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) --- NonEmpty lists (used for 'ProjectionE') -nonEmptyTyCon :: TyCon -nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon] - -nonEmptyDataCon :: DataCon -nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -} - nonEmptyDataConName - alpha_tyvar [] alpha_tyvar - (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) - nonEmptyTyCon - -- Wired-in type Maybe maybeTyCon :: TyCon @@ -2058,7 +2220,7 @@ mkTupleTy1 :: Boxity -> [Type] -> Type mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) - (map getRuntimeRep tys ++ tys) + (map getRuntimeRep tys ++ tys) -- | Build the type of a small tuple that holds the specified type of thing -- Flattens 1-tuples. See Note [One-tuples]. @@ -2067,6 +2229,18 @@ unitTy :: Type unitTy = mkTupleTy Boxed [] + +-- Make a constraint tuple, flattening a 1-tuple as usual +-- If we get a constraint tuple that is bigger than the pre-built +-- ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't +-- have an info table in the RTS, so we can't use it at runtime. But +-- this is used only in filling in extra-constraint wildcards, so it +-- never is used at runtime anyway +-- See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures] +mkConstraintTupleTy :: [Type] -> Type +mkConstraintTupleTy [ty] = ty +mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys + {- ********************************************************************* * * diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -1,7 +1,7 @@ module GHC.Builtin.Types where import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) -import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, RuntimeRepType) import {-# SOURCE #-} GHC.Core.DataCon ( DataCon ) import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag) @@ -16,8 +16,8 @@ unitTy :: Type - liftedTypeKindTyConName :: Name +constraintKindTyConName :: Name liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind @@ -33,7 +33,7 @@ boxedRepDataConTyCon, liftedDataConTyCon :: TyCon vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepTy, unliftedRepTy, zeroBitRepTy :: Type +liftedRepTy, unliftedRepTy, zeroBitRepTy :: RuntimeRepType liftedDataConTy, unliftedDataConTy :: Type intRepDataConTy, @@ -41,7 +41,7 @@ wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type @@ -64,7 +64,7 @@ multMulTyCon :: TyCon tupleTyConName :: TupleSort -> Arity -> Name - +tupleDataConName :: Boxity -> Arity -> Name integerTy, naturalTy :: Type diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -30,6 +30,8 @@ levity1TyVarInf, levity2TyVarInf, levity1Ty, levity2Ty, + alphaConstraintTyVar, alphaConstraintTy, + openAlphaTyVar, openBetaTyVar, openGammaTyVar, openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, openAlphaTy, openBetaTy, openGammaTy, @@ -41,13 +43,16 @@ multiplicityTyVar1, multiplicityTyVar2, -- Kind constructors... - tYPETyCon, tYPETyConName, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, - -- Kinds - mkTYPEapp, + -- Arrows + funTyFlagTyCon, isArrowTyCon, + fUNTyCon, fUNTyConName, + ctArrowTyCon, ctArrowTyConName, + ccArrowTyCon, ccArrowTyConName, + tcArrowTyCon, tcArrowTyConName, - functionWithMultiplicity, - funTyCon, funTyConName, unexposedPrimTyCons, exposedPrimTyCons, primTyCons, charPrimTyCon, charPrimTy, charPrimTyConName, @@ -80,6 +85,7 @@ weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, stackSnapshotPrimTyCon, stackSnapshotPrimTy, + promptTagPrimTyCon, mkPromptTagPrimTy, int8PrimTyCon, int8PrimTy, int8PrimTyConName, word8PrimTyCon, word8PrimTy, word8PrimTyConName, @@ -105,7 +111,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types - ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind + ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind, unliftedTypeKind , boxedRepDataConTyCon, vecRepDataConTyCon , liftedRepTy, unliftedRepTy, zeroBitRepTy , intRepDataConTy @@ -120,45 +126,134 @@ , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy - , multiplicityTy ) + , multiplicityTy + , constraintKind ) -import GHC.Types.Var ( TyVarBinder, TyVar +import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon ) +import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead + +import GHC.Types.Var ( TyVarBinder, TyVar,binderVar, binderVars , mkTyVar, mkTyVarBinder, mkTyVarBinders ) import GHC.Types.Name -import {-# SOURCE #-} GHC.Types.TyThing -import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique + import GHC.Builtin.Uniques import GHC.Builtin.Names -import GHC.Data.FastString import GHC.Utils.Misc ( changeLast ) -import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid - -- import loops which show up if you import Type instead -import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity ) +import GHC.Utils.Panic ( assertPpr ) +import GHC.Utils.Outputable +import GHC.Data.FastString import Data.Char -{- -************************************************************************ +{- ********************************************************************* * * -\subsection{Primitive type constructors} + Building blocks * * -************************************************************************ +********************************************************************* -} + +mk_TYPE_app :: Type -> Type +mk_TYPE_app rep = mkTyConApp tYPETyCon [rep] + +mk_CONSTRAINT_app :: Type -> Type +mk_CONSTRAINT_app rep = mkTyConApp cONSTRAINTTyCon [rep] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc = mkGenPrimTc UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc = mkGenPrimTc BuiltInSyntax + +mkGenPrimTc :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkGenPrimTc built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (mkATyCon tycon) + built_in_syntax + +-- | Create a primitive 'TyCon' with the given 'Name', +-- arguments of kind 'Type` with the given 'Role's, +-- and the given result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon :: Name + -> [Role] -> RuntimeRepType -> TyCon +pcPrimTyCon name roles res_rep + = mkPrimTyCon name binders result_kind roles + where + bndr_kis = liftedTypeKind <$ roles + binders = mkTemplateAnonTyConBinders bndr_kis + result_kind = mk_TYPE_app res_rep + +-- | Create a primitive nullary 'TyCon' with the given 'Name' +-- and result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon +pcPrimTyCon0 name res_rep + = pcPrimTyCon name [] res_rep + +-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last +-- argument is levity-polymorphic, where the levity argument is +-- implicit and comes before other arguments +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon_LevPolyLastArg :: Name + -> [Role] -- ^ roles of the arguments (must be non-empty), + -- not including the implicit argument of kind 'Levity', + -- which always has 'Nominal' role + -> RuntimeRepType -- ^ representation of the fully-applied type + -> TyCon +pcPrimTyCon_LevPolyLastArg name roles res_rep + = mkPrimTyCon name binders result_kind (Nominal : roles) + where + result_kind = mk_TYPE_app res_rep + lev_bndr = mkNamedTyConBinder Inferred levity1TyVar + binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis + lev_tv = mkTyVarTy (binderVar lev_bndr) + + -- [ Type, ..., Type, TYPE (BoxedRep l) ] + anon_bndr_kis = changeLast (liftedTypeKind <$ roles) $ + mk_TYPE_app $ + mkTyConApp boxedRepDataConTyCon [lev_tv] + + +{- ********************************************************************* +* * + Primitive type constructors +* * +********************************************************************* -} + +{- Note Note [Unexposed TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A few primitive TyCons are "unexposed", meaning: +* We don't want users to be able to write them (see #15209); + i.e. they aren't in scope, ever. In particular they do not + appear in the exports of GHC.Prim: see GHC.Builtin.Utils.ghcPrimExports + +* We don't want users to see them in GHCi's @:browse@ output (see #12023). -} primTyCons :: [TyCon] primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons --- | Primitive 'TyCon's that are defined in GHC.Prim but not exposed. --- It's important to keep these separate as we don't want users to be able to --- write them (see #15209) or see them in GHCi's @:browse@ output --- (see #12023). +-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed". +-- See Note [Unexposed TyCons] unexposedPrimTyCons :: [TyCon] unexposedPrimTyCons - = [ eqPrimTyCon - , eqReprPrimTyCon - , eqPhantPrimTyCon + = [ eqPrimTyCon -- (~#) + , eqReprPrimTyCon -- (~R#) + , eqPhantPrimTyCon -- (~P#) + + -- These arrows are un-exposed for now + , ctArrowTyCon -- (=>) + , ccArrowTyCon -- (==>) + , tcArrowTyCon -- (-=>) ] -- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim. @@ -198,28 +293,15 @@ , word32PrimTyCon , word64PrimTyCon , 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, @@ -231,7 +313,7 @@ stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, - stackSnapshotPrimTyConName :: Name + stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon @@ -275,14 +357,15 @@ weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon 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", ... ] -} @@ -369,13 +452,16 @@ mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] -- Makes named, Specified binders -mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] +mkTemplateKindTyConBinders kinds + = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] -mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) +mkTemplateAnonTyConBinders kinds + = mkAnonTyConBinders (mkTemplateTyVars kinds) mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] -mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) +mkTemplateAnonTyConBindersFrom n kinds + = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds) alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind @@ -386,13 +472,22 @@ 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 (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys alphaTyVarsUnliftedRep :: [TyVar] -alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (mkTYPEapp unliftedRepTy) +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat unliftedTypeKind alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep @@ -410,7 +505,7 @@ runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar -runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type +runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar @@ -419,7 +514,9 @@ -- beta :: TYPE r2 -- gamma :: TYPE r3 [openAlphaTyVar,openBetaTyVar,openGammaTyVar] - = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp runtimeRep3Ty] + = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty + , mk_TYPE_app runtimeRep3Ty] openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar @@ -448,8 +545,8 @@ levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar [levPolyAlphaTyVar, levPolyBetaTyVar] = mkTemplateTyVars - [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty]) - ,mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity2Ty])] + [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty]) + , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])] -- alpha :: TYPE ('BoxedRep l) -- beta :: TYPE ('BoxedRep k) @@ -474,80 +571,280 @@ ************************************************************************ -} -funTyConName :: Name -funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey funTyCon +{- Note [Function type constructors and FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have four distinct function type constructors, and a type synonym + FUN :: forall (m :: Multiplicity) -> + forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> TYPE rep2 -> Type + + (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> TYPE rep2 -> Type + + (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint + + (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> CONSTRAINT rep2 -> Constraint + + type (->) = FUN Many + +For efficiency, all four are always represented by + FunTy { ft_af :: FunTyFlag, ft_mult :: Mult + , ft_arg :: Type, ft_res :: Type } +rather than by using a TyConApp. + +* The four TyCons FUN, (=>), (==>), (-=>) are all wired in. + But (->) is just a regular synonym, with no special treatment; + in particular it is not wired-in. + +* The ft_af :: FunTyFlag distinguishes the four cases. + See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_af field is redundant: it can always be gleaned from + the kinds of ft_arg and ft_res. See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_mult :: Mult field gives the first argument for FUN + For the other three cases ft_mult is redundant; it is always Many. + Note that of the four type constructors, only `FUN` takes a Multiplicity. + +* Functions in GHC.Core.Type help to build and decompose `FunTy`. + * funTyConAppTy_maybe + * funTyFlagTyCon + * tyConAppFun_maybe + * splitFunTy_maybe + Use them! +-} + +funTyFlagTyCon :: FunTyFlag -> TyCon +-- `anonArgTyCon af` gets the TyCon that corresponds to the `FunTyFlag` +-- But be careful: fUNTyCon has a different kind to the others! +-- See Note [Function type constructors and FunTy] +funTyFlagTyCon FTF_T_T = fUNTyCon +funTyFlagTyCon FTF_T_C = tcArrowTyCon +funTyFlagTyCon FTF_C_T = ctArrowTyCon +funTyFlagTyCon FTF_C_C = ccArrowTyCon + +isArrowTyCon :: TyCon -> Bool +-- We don't bother to look for plain (->), because this function +-- should only be used after unwrapping synonyms +isArrowTyCon tc + = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc) + getUnique tc `elem` + [fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey] + +fUNTyConName, ctArrowTyConName, ccArrowTyConName, tcArrowTyConName :: Name +fUNTyConName = mkPrimTc (fsLit "FUN") fUNTyConKey fUNTyCon +ctArrowTyConName = mkBuiltInPrimTc (fsLit "=>") ctArrowTyConKey ctArrowTyCon +ccArrowTyConName = mkBuiltInPrimTc (fsLit "==>") ccArrowTyConKey ccArrowTyCon +tcArrowTyConName = mkBuiltInPrimTc (fsLit "-=>") tcArrowTyConKey tcArrowTyCon + -- | The @FUN@ type constructor. -- -- @ -- FUN :: forall (m :: Multiplicity) -> -- forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. --- TYPE rep1 -> TYPE rep2 -> * +-- TYPE rep1 -> TYPE rep2 -> Type -- @ -- -- The runtime representations quantification is left inferred. This -- means they cannot be specified with @-XTypeApplications@. -- -- This is a deliberate choice to allow future extensions to the --- function arrow. To allow visible application a type synonym can be --- defined: --- --- @ --- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --- TYPE rep1 -> TYPE rep2 -> Type --- type Arr = FUN 'Many --- @ --- -funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm +-- function arrow. +fUNTyCon :: TyCon +fUNTyCon = mkPrimTyCon fUNTyConName tc_bndrs liftedTypeKind tc_roles where -- See also unrestrictedFunTyCon tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1 , mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] - ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty - , mkTYPEapp runtimeRep2Ty - ] - tc_rep_nm = mkPrelTyConRepName funTyConName + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Nominal, Representational, Representational] +-- (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> TYPE rep2 -> Type +ctArrowTyCon :: TyCon +ctArrowTyCon = mkPrimTyCon ctArrowTyConName tc_bndrs liftedTypeKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint +ccArrowTyCon :: TyCon +ccArrowTyCon = mkPrimTyCon ccArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> CONSTRAINT rep2 -> Constraint +tcArrowTyCon :: TyCon +tcArrowTyCon = mkPrimTyCon tcArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + {- ************************************************************************ * * - Kinds + Type and Constraint * * ************************************************************************ -Note [TYPE and RuntimeRep] +Note [TYPE and CONSTRAINT] aka Note [Type vs Constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -All types that classify values have a kind of the form (TYPE rr), where +GHC distinguishes Type from Constraint throughout the compiler. +See GHC Proposal #518, and tickets #21623 and #11715. - data RuntimeRep -- Defined in ghc-prim:GHC.Types +All types that classify values have a kind of the form + (TYPE rr) or (CONSTRAINT rr) +where the `RuntimeRep` parameter, rr, tells us how the value is represented +at runtime. TYPE and CONSTRAINT are primitive type constructors. + +See Note [RuntimeRep polymorphism] about the `rr` parameter. + +There are a bunch of type synonyms and data types defined in the +library ghc-prim:GHC.Types. All of them are also wired in to GHC, in +GHC.Builtin.Types + + type Constraint = CONSTRAINT LiftedRep :: Type + + type Type = TYPE LiftedRep :: Type + type UnliftedType = TYPE UnliftedRep :: Type + + type LiftedRep = BoxedRep Lifted :: RuntimeRep + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep + + data RuntimeRep -- Defined in ghc-prim:GHC.Types = BoxedRep Levity | IntRep | FloatRep .. etc .. - data Levity = Lifted | Unlifted - - rr :: RuntimeRep + data Levity = Lifted | Unlifted - TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in +We abbreviate '*' specially (with -XStarIsType), as if we had this: + type * = Type So for example: - Int :: TYPE ('BoxedRep 'Lifted) - Array# Int :: TYPE ('BoxedRep 'Unlifted) - Int# :: TYPE 'IntRep - Float# :: TYPE 'FloatRep - Maybe :: TYPE ('BoxedRep 'Lifted) -> TYPE ('BoxedRep 'Lifted) + Int :: TYPE (BoxedRep Lifted) + Array# Int :: TYPE (BoxedRep Unlifted) + Int# :: TYPE IntRep + Float# :: TYPE FloatRep + Maybe :: TYPE (BoxedRep Lifted) -> TYPE (BoxedRep Lifted) (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) -We abbreviate '*' specially: - type LiftedRep = 'BoxedRep 'Lifted - type * = TYPE LiftedRep + Eq Int :: CONSTRAINT (BoxedRep Lifted) + IP "foo" Int :: CONSTRAINT (BoxedRep Lifted) + a ~ b :: CONSTRAINT (BoxedRep Lifted) + a ~# b :: CONSTRAINT (TupleRep []) -The 'rr' parameter tells us how the value is represented at runtime. +Constraints are mostly lifted, but unlifted ones are useful too. +Specifically (a ~# b) :: CONSTRAINT (TupleRep []) -Generally speaking, you can't be polymorphic in 'rr'. E.g +Wrinkles + +(W1) Type and Constraint are considered distinct throughout GHC. But they + are not /apart/: see Note [Type and Constraint are not apart] + +(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and + aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint. Ditto noInlineId + vs noInlieConstraintId in GHC.Types.Id.Make; see Note [inlineId magic]. + +(W3) We need a TypeOrConstraint flag in LitRubbish. + +Note [Type and Constraint are not apart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type and Constraint are not equal (eqType) but they are not /apart/ +either. Reason (c.f. #7451): + +* We want to allow newtype classes, where + class C a where { op :: a -> a } + +* The axiom for such a class will look like + axiom axC a :: (C a :: Constraint) ~# (a->a :: Type) + +* This axiom connects a type of kind Type with one of kind Constraint + That is dangerous: kindCo (axC Int) :: Type ~N Constraint + And /that/ is bad because we could have + type family F a where + F Type = Int + F Constraint = Bool + So now we can prove Int ~N Bool, and all is lost. We prevent this + by saying that Type and Constraint are not Apart, which makes the + above type family instances illegal. + +So we ensure that Type and Constraint are not apart; or, more +precisely, that TYPE and CONSTRAINT are not apart. This +non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look +for `maybeApart MARTypeVsConstraint`. + +Note that, as before, nothing prevents writing instances like: + + instance C (Proxy @Type a) where ... + +In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint +etc) are all allowed in instance heads. It's just that TYPE is not +apart from CONSTRAINT, which means that the above instance would +irretrievably overlap with: + + instance C (Proxy @Constraint a) where ... + +Wrinkles + +(W1) In GHC.Core.RoughMap.roughMtchTyConName we are careful to map + TYPE and CONSTRAINT to the same rough-map key. Reason: + If we insert (F @Constraint tys) into a FamInstEnv, and look + up (F @Type tys'), we /must/ ensure that the (C @Constraint tys) + appears among the unifiables when we do the lookupRM' in + GHC.Core.FamInstEnv.lookup_fam_inst_env'. So for the RoughMap we + simply pretend that they are the same type constructor. If we + don't, we'll treat them as fully apart, which is unsound. + +(W2) We must extend this treatment to the different arrow types (see + Note [Function type constructors and FunTy]): if we have + FunCo (axC Int) :: (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 @@ -572,85 +869,40 @@ (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). a -> b -> TYPE ('TupleRep '[r1, r2]) - -} +---------------------- tYPETyCon :: TyCon -tYPETyConName :: Name - tYPETyCon = mkPrimTyCon tYPETyConName (mkTemplateAnonTyConBinders [runtimeRepTy]) liftedTypeKind [Nominal] --------------------------- --- ... and now their names +tYPETyConName :: Name +tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon --- If you edit these, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -tYPETyConName = mkPrimTcName UserSyntax (fsLit "TYPE") tYPETyConKey tYPETyCon +tYPEKind :: Type +tYPEKind = mkTyConTy tYPETyCon -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name -mkPrimTcName built_in_syntax occ key tycon - = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax +---------------------- +cONSTRAINTTyCon :: TyCon +cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] ------------------------------ +cONSTRAINTTyConName :: Name +cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon --- Given a Multiplicity, applies FUN to it. -functionWithMultiplicity :: Type -> Type -functionWithMultiplicity mul = TyConApp funTyCon [mul] +cONSTRAINTKind :: Type +cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon -{- -************************************************************************ + +{- ********************************************************************* * * - Basic primitive types (@Char#@, @Int#@, etc.) + Basic primitive types (Char#, Int#, etc.) * * -************************************************************************ --} - --- | Create a primitive 'TyCon' with the given 'Name', --- arguments of kind 'Type` with the given 'Role's, --- and the given result kind representation. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon :: Name - -> [Role] -> RuntimeRepType -> TyCon -pcPrimTyCon name roles res_rep - = mkPrimTyCon name binders result_kind roles - where - bndr_kis = liftedTypeKind <$ roles - binders = mkTemplateAnonTyConBinders bndr_kis - result_kind = mkTYPEapp res_rep - --- | Create a primitive nullary 'TyCon' with the given 'Name' --- and result kind representation. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon -pcPrimTyCon0 name res_rep - = pcPrimTyCon name [] res_rep - --- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last --- argument is levity-polymorphic. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon_LevPolyLastArg :: Name - -> [Role] -- ^ roles of the arguments (must be non-empty), - -- not including the implicit argument of kind 'Levity', - -- which always has 'Nominal' role - -> RuntimeRepType -- ^ representation of the fully-applied type - -> TyCon -pcPrimTyCon_LevPolyLastArg name roles res_rep - = mkPrimTyCon name binders result_kind (Nominal : roles) - where - result_kind = mkTYPEapp res_rep - lev_bndr = mkNamedTyConBinder Inferred levity1TyVar - binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis - lev_tv = mkTyVarTy (binderVar lev_bndr) - - -- [ Type, ..., Type, TYPE (BoxedRep l) ] - anon_bndr_kis = changeLast (liftedTypeKind <$ roles) - (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv]) +********************************************************************* -} charPrimTy :: Type charPrimTy = mkTyConTy charPrimTyCon @@ -821,6 +1073,8 @@ * In addition (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported or imported. + * The data constructor of the class is "Eq#", not ":C~" + Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types. Historical note: prior to July 18 (~) was defined as a @@ -924,10 +1178,7 @@ realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld --- Note: the ``state-pairing'' types are not truly primitive, --- so they are defined in \tr{GHC.Builtin.Types}, not here. - mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] @@ -950,9 +1201,9 @@ -- See Note [The equality types story] eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions @@ -961,9 +1212,9 @@ eqReprPrimTyCon :: TyCon -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Representational, Representational] -- like eqPrimTyCon, but the type for *Phantom* coercions. @@ -972,9 +1223,9 @@ eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Phantom, Phantom] -- | Given a Role, what TyCon is the type of equality predicates at that role? @@ -1176,6 +1427,20 @@ threadIdPrimTy = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy + +{- +************************************************************************ +* * + The ``prompt tag'' type +* * +************************************************************************ +-} + +promptTagPrimTyCon :: TyCon +promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy + +mkPromptTagPrimTy :: Type -> Type +mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v] {- ************************************************************************ diff --git a/compiler/GHC/Builtin/Types/Prim.hs-boot b/compiler/GHC/Builtin/Types/Prim.hs-boot deleted file mode 100644 --- 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 --- a/compiler/GHC/Builtin/Uniques.hs +++ b/compiler/GHC/Builtin/Uniques.hs @@ -13,8 +13,8 @@ -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums - , mkSumTyConUnique - , mkSumDataConUnique + , mkSumTyConUnique, mkSumDataConUnique + -- ** Tuples -- *** Vanilla , mkTupleTyConUnique @@ -37,7 +37,7 @@ , mkBuiltinUnique , mkPseudoUniqueE - -- ** Deriving uniquesc + -- ** Deriving uniques -- *** From TyCon name uniques , tyConRepNameUnique -- *** From DataCon name uniques @@ -45,6 +45,9 @@ , initExitJoinUnique + -- Boxing data types + , mkBoxingTyConUnique, boxingDataConUnique + ) where import GHC.Prelude @@ -60,7 +63,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Maybe @@ -107,8 +109,9 @@ mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity = - assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the - -- alternative + assertPpr (arity <= 0x3f) (ppr arity) $ + -- 0x3f since we only have 6 bits to encode the + -- alternative mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) mkSumDataConUnique :: ConTagZ -> Arity -> Unique @@ -297,6 +300,7 @@ other a-z: lower case chars for unique supplies. Used so far: a TypeChecking? + b Boxing tycons & datacons c StgToCmm/Renamer d desugarer f AbsC flattener @@ -310,6 +314,27 @@ u Cmm pipeline y GHCi bytecode generator z anonymous sums + +Note [Related uniques for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* All wired in tycons actually use *two* uniques: + * u: the TyCon itself + * u+1: the TyConRepName of the TyCon (for use with TypeRep) + The "+1" is implemented in tyConRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* All wired in datacons use *three* uniques: + * u: the DataCon itself + * u+1: its worker Id + * u+2: the TyConRepName of the promoted TyCon + No wired-in datacons have wrappers. + The "+1" is implemented in dataConWorkerUnique and the "+2" is in dataConTyRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* Because boxing tycons (see Note [Boxing constructors] in GHC.Builtin.Types) + come with both a tycon and a datacon, each one takes up five slots, combining + the two cases above. Getting from the tycon to the datacon (by adding 2) + is implemented in boxingDataConUnique. -} mkAlphaTyVarUnique :: Int -> Unique @@ -351,29 +376,48 @@ initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 - -------------------------------------------------- -- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon +-- See Note [Related uniques for wired-in things] mkPreludeTyConUnique :: Int -> Unique -mkPreludeTyConUnique i = mkUnique '3' (2*i) +mkPreludeTyConUnique i = mkUnique '3' (2*i) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u -------------------------------------------------- -- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. +-- See Note [Related uniques for wired-in things] mkPreludeDataConUnique :: Int -> Unique -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic --------------------------------------------------- dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +-- The data constructors of RuntimeRep occupy *five* slots: +-- See Note [Related uniques for wired-in things] +-- +-- Example: WordRep +-- +-- * u: the TyCon of the boxing data type WordBox +-- * u+1: the TyConRepName of the boxing data type +-- * u+2: the DataCon for MkWordBox +-- * u+3: the worker id for MkWordBox +-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox +-- +-- Note carefully that +-- * u,u+1 are in sync with the conventions for +-- wired-in type constructors, above +-- * u+2,u+3,u+4 are in sync with the conventions for +-- wired-in data constructors, above +-- A little delicate! + +mkBoxingTyConUnique :: Int -> Unique +mkBoxingTyConUnique i = mkUnique 'b' (5*i) + +boxingDataConUnique :: Unique -> Unique +boxingDataConUnique u = stepUnique u 2 diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -120,7 +121,7 @@ ppr NativeCallInfo{..} = text " ppr nativeCallSize <+> text "stack" <+> ppr nativeCallStackSpillSize <+> text "regs" <+> - ppr (map (text . show) $ regSetToList nativeCallRegs) <> + ppr (map (text @SDoc . show) $ regSetToList nativeCallRegs) <> char '>' diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -6,13 +6,17 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyCase #-} module GHC.Cmm ( -- * Cmm top-level datatypes CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, CmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmDataDecl, cmmDataDeclCmmDecl, CmmGraph, GenCmmGraph(..), + toBlockMap, revPostorder, toBlockList, CmmBlock, RawCmmDecl, Section(..), SectionType(..), GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), @@ -30,10 +34,14 @@ -- * Statements, expressions and types module GHC.Cmm.Node, module GHC.Cmm.Expr, + + -- * Pretty-printing + pprCmmGroup, pprSection, pprStatic ) where import GHC.Prelude +import GHC.Platform import GHC.Types.Id import GHC.Types.CostCentre import GHC.Cmm.CLabel @@ -46,7 +54,11 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable + +import Data.Void (Void) +import Data.List (intersperse) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS ----------------------------------------------------------------------------- -- Cmm, GenCmm @@ -102,9 +114,21 @@ deriving (Functor) +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => OutputableP Platform (GenCmmDecl d info i) where + pdoc = pprTop + type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph +type CmmDataDecl = GenCmmDataDecl CmmStatics +type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded +cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g +cmmDataDeclCmmDecl = \ case + CmmProc void _ _ _ -> case void of + CmmData section d -> CmmData section d +{-# INLINE cmmDataDeclCmmDecl #-} + type RawCmmDecl = GenCmmDecl RawCmmStatics @@ -119,6 +143,29 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C +instance OutputableP Platform CmmGraph where + pdoc = pprCmmGraph + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map (pdoc platform) blocks) + $$ text "}" + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + ----------------------------------------------------------------------------- -- Info Tables ----------------------------------------------------------------------------- @@ -128,6 +175,14 @@ data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable , stack_info :: CmmStackInfo } +instance OutputableP Platform CmmTopInfo where + pdoc = pprTopInfo + +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [text "info_tbls: " <> pdoc platform info_tbl, + text "stack_info: " <> ppr stack_info] + topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _ = Nothing @@ -145,6 +200,13 @@ -- we want to do the stack manipulation manually. } +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space + -- | Info table as a haskell data type data CmmInfoTable = CmmInfoTable { @@ -169,6 +231,10 @@ -- GHC.Cmm.Info.Build.doSRTs. } deriving Eq +instance OutputableP Platform CmmInfoTable where + pdoc = pprInfoTable + + data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc @@ -183,7 +249,6 @@ | ReadOnlyData | RelocatableReadOnlyData | UninitialisedData - | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini | InitArray -- .init_array on ELF, .ctor on Windows | FiniArray -- .fini_array on ELF, .dtor on Windows @@ -203,7 +268,6 @@ Text -> ReadOnlySection ReadOnlyData -> ReadOnlySection RelocatableReadOnlyData -> WriteProtectedSection - ReadOnlyData16 -> ReadOnlySection InitArray -> ReadOnlySection FiniArray -> ReadOnlySection CString -> ReadOnlySection @@ -230,14 +294,17 @@ -- ^ uninitialised data, N bytes long | CmmString ByteString -- ^ string of 8-bit values only, not zero terminated. - | CmmFileEmbed FilePath - -- ^ an embedded binary file + | CmmFileEmbed FilePath Int + -- ^ an embedded binary file and its byte length +instance OutputableP Platform CmmStatic where + pdoc = pprStatic + instance Outputable CmmStatic where ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n ppr (CmmString _) = text "CmmString" - ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp + ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp -- Static data before SRT generation data GenCmmStatics (rawOnly :: Bool) where @@ -246,6 +313,9 @@ -> CmmInfoTable -> CostCentreStack -> [CmmLit] -- Payload + -> [CmmLit] -- Non-pointers that go to the end of the closure + -- This is used by stg_unpack_cstring closures. + -- See Note [unpack_cstring closures] in StgStdThunks.cmm. -> GenCmmStatics 'False -- | Static data, after SRTs are generated @@ -254,6 +324,9 @@ -> [CmmStatic] -- The static data itself -> GenCmmStatics a +instance OutputableP Platform (GenCmmStatics a) where + pdoc = pprStatics + type CmmStatics = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True @@ -293,3 +366,115 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + + +-- -------------------------------------------------------------------------- +-- Pretty-printing Cmm +-- -------------------------------------------------------------------------- +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. + +pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) + => Platform -> GenCmmGroup d info g -> SDoc +pprCmmGroup platform tops + = vcat $ intersperse blankLine $ map (pprTop platform) tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- + +pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => Platform -> GenCmmDecl d info i -> SDoc + +pprTop platform (CmmProc info lbl live graph) + + = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live + , nest 8 $ lbrace <+> pdoc platform info $$ rbrace + , nest 4 $ pdoc platform graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- + +pprTop platform (CmmData section ds) = + (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Pretty-printing info tables +-- -------------------------------------------------------------------------- + +pprInfoTable :: Platform -> CmmInfoTable -> SDoc +pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = srt }) + = vcat [ text "label: " <> pdoc platform lbl + , text "rep: " <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> + vcat [ text "type: " <> text (show (BS.unpack ct)) + , text "desc: " <> text (show (BS.unpack cd)) ] + , text "srt: " <> pdoc platform srt ] + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- + +pprStatics :: Platform -> GenCmmStatics a -> SDoc +pprStatics platform (CmmStatics lbl itbl ccs payload extras) = + pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras +pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ text "const" <+> pdoc platform lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path) + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Platform -> Section -> SDoc +pprSection platform (Section t suffix) = + section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) + where + section = text "section" + +pprSectionType :: SectionType -> SDoc +pprSectionType s = doubleQuotes $ case s of + Text -> text "text" + Data -> text "data" + ReadOnlyData -> text "readonly" + RelocatableReadOnlyData -> text "relreadonly" + UninitialisedData -> text "uninitialised" + InitArray -> text "initarray" + FiniArray -> text "finiarray" + CString -> text "cstring" + OtherSection s' -> text s' diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs --- a/compiler/GHC/Cmm/BlockId.hs +++ b/compiler/GHC/Cmm/BlockId.hs @@ -11,6 +11,7 @@ import GHC.Prelude import GHC.Cmm.CLabel +import GHC.Data.FastString import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique @@ -43,4 +44,4 @@ infoTblLbl :: BlockId -> CLabel infoTblLbl label - = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs + = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Object-file symbols (called CLabel for histerical raisins). +-- Object-file symbols (called CLabel for historical reasons). -- -- (c) The University of Glasgow 2004-2006 -- @@ -65,7 +65,6 @@ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, mkOutOfBoundsAccessLabel, - mkMemcpyRangeOverlapLabel, mkArrWords_infoLabel, mkSRTInfoLabel, @@ -73,6 +72,8 @@ mkCAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, mkRtsSlowFastTickyCtrLabel, + mkRtsUnpackCStringLabel, + mkRtsUnpackCStringUtf8Label, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -109,6 +110,7 @@ isLocalCLabel, mayRedirectTo, isInfoTableLabel, + isCmmInfoTableLabel, isConInfoTableLabel, isIdLabel, isTickyLabel, @@ -129,6 +131,7 @@ LabelStyle (..), pprDebugCLabel, pprCLabel, + pprAsmLabel, ppInternalProcLabel, -- * Others @@ -153,10 +156,11 @@ import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set -import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.Types.SrcLoc +import qualified Data.Semigroup as S + -- ----------------------------------------------------------------------------- -- The CLabel type @@ -295,23 +299,22 @@ instance Show CLabel where show = showPprUnsafe . pprDebugCLabel genericPlatform -instance Outputable CLabel where - ppr = text . show - data ModuleLabelKind - = MLK_Initializer String + = MLK_Initializer LexicalFastString | MLK_InitializerArray - | MLK_Finalizer String + | MLK_Finalizer LexicalFastString | MLK_FinalizerArray | MLK_IPEBuffer deriving (Eq, Ord) -instance Outputable ModuleLabelKind where - ppr MLK_InitializerArray = text "init_arr" - ppr (MLK_Initializer s) = text ("init__" ++ s) - ppr MLK_FinalizerArray = text "fini_arr" - ppr (MLK_Finalizer s) = text ("fini__" ++ s) - ppr MLK_IPEBuffer = text "ipe_buf" +pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc +pprModuleLabelKind MLK_InitializerArray = text "init_arr" +pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s +pprModuleLabelKind MLK_FinalizerArray = text "fini_arr" +pprModuleLabelKind (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s +pprModuleLabelKind MLK_IPEBuffer = text "ipe_buf" +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-} +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True @@ -348,26 +351,26 @@ -- code-generation. See Note [Unique Determinism and code generation] instance Ord CLabel where compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` + compare a1 a2 S.<> + compare b1 b2 S.<> compare c1 c2 compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` + compare a1 a2 S.<> + compare b1 b2 S.<> -- This non-determinism is "safe" in the sense that it only affects object code, -- which is currently not covered by GHC's determinism guarantees. See #12935. - uniqCompareFS c1 c2 `thenCmp` + uniqCompareFS c1 c2 S.<> compare d1 d2 compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = - uniqCompareFS a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` + uniqCompareFS a1 a2 S.<> + compare b1 b2 S.<> + compare c1 c2 S.<> compare d1 d2 compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> lexicalCompareFS b1 b2 compare (StringLitLabel u1) (StringLitLabel u2) = nonDetCmpUnique u1 u2 @@ -378,10 +381,10 @@ compare (IPE_Label a1) (IPE_Label a2) = compare a1 a2 compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) = - compare m1 m2 `thenCmp` + compare m1 m2 S.<> compare k1 k2 compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> compare b1 b2 compare PicBaseLabel PicBaseLabel = EQ compare (DeadStripPreventer a1) (DeadStripPreventer a2) = @@ -454,7 +457,7 @@ -- The regular Outputable instance only shows the label name, and not its other info. -- pprDebugCLabel :: Platform -> CLabel -> SDoc -pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra +pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra where extra = case lbl of IdLabel _ _ info @@ -563,6 +566,8 @@ | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks | RtsApEntry Bool{-updatable-} Int{-arity-} + | RtsUnpackCStringInfoTable + | RtsUnpackCStringUtf8InfoTable | RtsPrimOp PrimOp | RtsApFast NonDetFastString -- ^ _fast versions of generic apply | RtsSlowFastTickyCtr String @@ -617,7 +622,7 @@ mkConInfoTableLabel :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel :: Name -> CLabel mkClosureLabel name c = IdLabel name c Closure --- | Decicdes between external and local labels based on the names externality. +-- | Decides between external and local labels based on the names externality. mkInfoTableLabel name c | isExternalName name = IdLabel name c InfoTable | otherwise = IdLabel name c LocalInfoTable @@ -644,8 +649,7 @@ mkCAFBlackHoleInfoTableLabel, mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, - mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel, - mkMUT_VAR_CLEAN_infoLabel :: CLabel + mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData @@ -663,8 +667,7 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry -mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction -mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction +mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo mkSRTInfoLabel :: Int -> CLabel @@ -737,7 +740,6 @@ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ RtsLabel (RtsApEntry upd arity) - -- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel mkPrimCallLabel (PrimCall str pkg) @@ -800,8 +802,14 @@ isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True isInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True +isInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True isInfoTableLabel _ = False +-- | Whether label points to an info table defined in Cmm +isCmmInfoTableLabel :: CLabel -> Bool +isCmmInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True +isCmmInfoTableLabel _ = False + -- | Whether label is points to constructor info table isConInfoTableLabel :: CLabel -> Bool isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True @@ -832,6 +840,9 @@ -- Position and information about the info table deriving (Eq, Ord) +instance OutputableP Platform InfoProvEnt where + pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel + -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel @@ -846,6 +857,11 @@ mkRtsSlowFastTickyCtrLabel :: String -> CLabel mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) +-- | A standard string unpacking thunk. See Note [unpack_cstring closures] in +-- StgStdThunks.cmm. +mkRtsUnpackCStringLabel, mkRtsUnpackCStringUtf8Label :: CLabel +mkRtsUnpackCStringLabel = RtsLabel RtsUnpackCStringInfoTable +mkRtsUnpackCStringUtf8Label = RtsLabel RtsUnpackCStringUtf8InfoTable -- Constructing Code Coverage Labels mkHpcTicksLabel :: Module -> CLabel @@ -871,15 +887,15 @@ mkStringLitLabel :: Unique -> CLabel mkStringLitLabel = StringLitLabel -mkInitializerStubLabel :: Module -> String -> CLabel -mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer s) +mkInitializerStubLabel :: Module -> FastString -> CLabel +mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer (LexicalFastString s)) mkInitializerArrayLabel :: Module -> CLabel mkInitializerArrayLabel mod = ModuleLabel mod MLK_InitializerArray -mkFinalizerStubLabel :: Module -> String -> CLabel -mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer s) +mkFinalizerStubLabel :: Module -> FastString -> CLabel +mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer (LexicalFastString s)) mkFinalizerArrayLabel :: Module -> CLabel mkFinalizerArrayLabel mod = ModuleLabel mod MLK_FinalizerArray @@ -952,6 +968,9 @@ hasCAF :: CLabel -> Bool hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE] hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF (RtsLabel RtsUnpackCStringInfoTable) = True +hasCAF (RtsLabel RtsUnpackCStringUtf8InfoTable) = True + -- The info table stg_MK_STRING_info is for thunks hasCAF _ = False -- Note [ticky for LNE] @@ -1187,9 +1206,15 @@ labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel labelType (CmmLabel _ _ _ CmmRet) = CodeLabel labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsSelectorEntry _ _)) = CodeLabel labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApEntry _ _)) = CodeLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel -labelType (RtsLabel _) = DataLabel +labelType (RtsLabel RtsUnpackCStringInfoTable) = DataLabel +labelType (RtsLabel RtsUnpackCStringUtf8InfoTable) + = DataLabel +labelType (RtsLabel (RtsPrimOp _)) = CodeLabel +labelType (RtsLabel (RtsSlowFastTickyCtr _)) = DataLabel labelType (LocalBlockLabel _) = CodeLabel labelType (SRTLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -1359,7 +1384,6 @@ ordinary Haskell function of arity 1 that allocates a (Just x) box: Just = \x -> Just x - Just_entry: The entry code for the worker function Just_closure: The closure for this worker Nothing_closure: a statically allocated closure for Nothing @@ -1397,49 +1421,71 @@ -} +-- | Style of label pretty-printing. +-- +-- When we produce C sources or headers, we have to take into account that C +-- compilers transform C labels when they convert them into symbols. For +-- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for +-- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style +-- or Asm style. +-- +data LabelStyle + = CStyle -- ^ C label style (used by C and LLVM backends) + | AsmStyle -- ^ Asm label style (used by NCG backend) + +pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc +pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprCLabel :: IsLine doc => Platform -> CLabel -> doc +pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + instance OutputableP Platform CLabel where {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] pdoc !platform lbl = getPprStyle $ \pp_sty -> - let !sty = case pp_sty of - PprCode sty -> sty - _ -> CStyle - in pprCLabel platform sty lbl + case pp_sty of + PprDump{} -> pprCLabel platform lbl + _ -> let lbl_doc = (pprCLabel platform lbl) + in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc -pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] +pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc +pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel] let !use_leading_underscores = platformLeadingUnderscore platform -- some platform (e.g. Darwin) require a leading "_" for exported asm -- symbols - maybe_underscore :: SDoc -> SDoc + maybe_underscore :: doc -> doc maybe_underscore doc = case sty of AsmStyle | use_leading_underscores -> pp_cSEP <> doc _ -> doc - tempLabelPrefixOrUnderscore :: Platform -> SDoc - tempLabelPrefixOrUnderscore platform = case sty of + tempLabelPrefixOrUnderscore :: doc + tempLabelPrefixOrUnderscore = case sty of AsmStyle -> asmTempLabelPrefix platform CStyle -> char '_' in case lbl of LocalBlockLabel u -> case sty of - AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u - CStyle -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u + AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u + CStyle -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u AsmTempLabel u - -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u + -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u AsmTempDerivedLabel l suf -> asmTempLabelPrefix platform <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel platform sty l + _other -> pprCLabelStyle platform sty l <> ftext suf DynamicLinkerLabel info lbl - -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl) + -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl) PicBaseLabel -> text "1b" @@ -1452,7 +1498,7 @@ optional `_` (underscore) because this is how you mark non-temp symbols on some platforms (Darwin) -} - maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp" + maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp" StringLitLabel u -> maybe_underscore $ pprUniqueAlways u <> text "_str" @@ -1469,69 +1515,74 @@ IdLabel name _cafs flavor -> case sty of - AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor + AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor where isRandomGenerated = not (isExternalName name) internalNamePrefix = if isRandomGenerated then asmTempLabelPrefix platform else empty - CStyle -> ppr name <> ppIdFlavor flavor + CStyle -> pprName name <> ppIdFlavor flavor SRTLabel u - -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt" + -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt" RtsLabel (RtsApFast (NonDetFastString str)) -> maybe_underscore $ ftext str <> text "_fast" RtsLabel (RtsSelectorInfoTable upd_reqd offset) - -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset , if upd_reqd then text "_upd_info" else text "_noupd_info" ] RtsLabel (RtsSelectorEntry upd_reqd offset) - -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset , if upd_reqd then text "_upd_entry" else text "_noupd_entry" ] RtsLabel (RtsApInfoTable upd_reqd arity) - -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity , if upd_reqd then text "_upd_info" else text "_noupd_info" ] RtsLabel (RtsApEntry upd_reqd arity) - -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity , if upd_reqd then text "_upd_entry" else text "_noupd_entry" ] RtsLabel (RtsPrimOp primop) - -> maybe_underscore $ text "stg_" <> ppr primop + -> maybe_underscore $ text "stg_" <> pprPrimOp primop RtsLabel (RtsSlowFastTickyCtr pat) -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr" + RtsLabel RtsUnpackCStringInfoTable + -> maybe_underscore $ text "stg_unpack_cstring_info" + RtsLabel RtsUnpackCStringUtf8InfoTable + -> maybe_underscore $ text "stg_unpack_cstring_utf8_info" + LargeBitmapLabel u - -> maybe_underscore $ tempLabelPrefixOrUnderscore platform + -> maybe_underscore $ tempLabelPrefixOrUnderscore <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm" -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7') -- until that gets resolved we'll just force them to start -- with a letter so the label will be legal assembly code. HpcTicksLabel mod - -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc" + -> maybe_underscore $ text "_hpc_tickboxes_" <> pprModule mod <> text "_hpc" - CC_Label cc -> maybe_underscore $ ppr cc - CCS_Label ccs -> maybe_underscore $ ppr ccs - IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe") - ModuleLabel mod kind -> maybe_underscore $ ppr mod <> text "_" <> ppr kind + CC_Label cc -> maybe_underscore $ pprCostCentre cc + CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> pprModule m <> text "_ipe") + ModuleLabel mod kind -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs @@ -1541,6 +1592,8 @@ CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info" CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret" CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure" +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [Internal proc labels] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1561,21 +1614,24 @@ -- | Generate a label for a procedure internal to a module (if -- 'Opt_ExposeAllSymbols' is enabled). -- See Note [Internal proc labels]. -ppInternalProcLabel :: Module -- ^ the current module +ppInternalProcLabel :: IsLine doc + => Module -- ^ the current module -> CLabel - -> Maybe SDoc -- ^ the internal proc label + -> Maybe doc -- ^ the internal proc label ppInternalProcLabel this_mod (IdLabel nm _ flavour) | isInternalName nm = Just - $ text "_" <> ppr this_mod + $ text "_" <> pprModule this_mod <> char '_' <> ztext (zEncodeFS (occNameFS (occName nm))) <> char '_' <> pprUniqueAlways (getUnique nm) <> ppIdFlavor flavour ppInternalProcLabel _ _ = Nothing +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-} +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor :: IsLine doc => IdLabelInfo -> doc ppIdFlavor x = pp_cSEP <> case x of Closure -> text "closure" InfoTable -> text "info" @@ -1586,22 +1642,22 @@ IdTickyInfo TickyRednCounts -> text "ct" IdTickyInfo (TickyInferedTag unique) - -> text "ct_inf_tag" <> char '_' <> ppr unique + -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique ConEntry loc -> case loc of DefinitionSite -> text "con_entry" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry" ConInfoTable k -> case k of DefinitionSite -> text "con_info" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info" ClosureTable -> text "closure_tbl" Bytes -> text "bytes" BlockInfoTable -> text "info" -pp_cSEP :: SDoc +pp_cSEP :: IsLine doc => doc pp_cSEP = char '_' @@ -1615,13 +1671,13 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> SDoc -- for formatting labels +asmTempLabelPrefix :: IsLine doc => Platform -> doc -- for formatting labels asmTempLabelPrefix !platform = case platformOS platform of OSDarwin -> text "L" OSAIX -> text "__L" -- follow IBM XL C's convention _ -> text ".L" -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc +pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = case platformOS platform of OSDarwin diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot --- a/compiler/GHC/Cmm/CLabel.hs-boot +++ b/compiler/GHC/Cmm/CLabel.hs-boot @@ -5,5 +5,4 @@ data CLabel -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc - +pprCLabel :: IsLine doc => Platform -> CLabel -> doc diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs --- a/compiler/GHC/Cmm/Dataflow/Graph.hs +++ b/compiler/GHC/Cmm/Dataflow/Graph.hs @@ -12,6 +12,7 @@ , NonLocal(..) , addBlock , bodyList + , bodyToBlockList , emptyBody , labelsDefined , mapGraph @@ -55,6 +56,9 @@ bodyList :: Body' block n -> [(Label,block n C C)] bodyList body = mapToList body + +bodyToBlockList :: Body n -> [Block n C C] +bodyToBlockList body = mapElems body addBlock :: (NonLocal block, HasDebugCallStack) diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -140,7 +140,6 @@ lookupTM k m = mapLookup k m alterTM k f m = mapAlter f k m foldTM k m z = mapFoldr k z m - mapTM f m = mapMap f m filterTM f m = mapFilter f m ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -10,6 +10,7 @@ , CmmReg(..), cmmRegType, cmmRegWidth , CmmLit(..), cmmLitType , AlignmentSpec(..) + -- TODO: Remove: , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType , spReg, hpReg, spLimReg, hpLimReg, nodeReg @@ -26,6 +27,11 @@ , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , regSetToList + , isTrivialCmmExpr + , hasNoGlobalRegs + , isLit + , isComparisonExpr + , Area(..) , module GHC.Cmm.MachOp , module GHC.Cmm.Type @@ -39,12 +45,14 @@ import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type +import GHC.Cmm.Reg import GHC.Utils.Panic (panic) import GHC.Utils.Outputable -import GHC.Types.Unique +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set +import Numeric ( fromRat ) import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) @@ -78,14 +86,12 @@ CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 _e1 == _e2 = False +instance OutputableP Platform CmmExpr where + pdoc = pprExpr + data AlignmentSpec = NaturallyAligned | Unaligned deriving (Eq, Ord, Show) -data CmmReg - = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord, Show ) - -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed. data Area @@ -94,6 +100,14 @@ -- See Note [Continuation BlockIds] in GHC.Cmm.Node. deriving (Eq, Ord, Show) +instance Outputable Area where + ppr e = pprArea e + +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + + {- Note [Old Area] ~~~~~~~~~~~~~~~~~~ There is a single call area 'Old', allocated at the extreme old @@ -217,6 +231,9 @@ -- of bytes used deriving (Eq, Show) +instance OutputableP Platform CmmLit where + pdoc = pprLit + instance Outputable CmmLit where ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w @@ -276,39 +293,35 @@ return (CmmMachOp op' args) maybeInvertCmmExpr _ = Nothing ------------------------------------------------------------------------------ --- Local registers ------------------------------------------------------------------------------ +--------------------------------------------------- +-- CmmExpr predicates +--------------------------------------------------- -data LocalReg - = LocalReg {-# UNPACK #-} !Unique !CmmType - -- ^ Parameters: - -- 1. Identifier - -- 2. Type - deriving Show +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" -instance Eq LocalReg where - (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord LocalReg where - compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False -instance Uniquable LocalReg where - getUnique (LocalReg uniq _) = uniq +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False -cmmRegType :: Platform -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: Platform -> CmmReg -> Width -cmmRegWidth platform = typeWidth . cmmRegType platform - -localRegType :: LocalReg -> CmmType -localRegType (LocalReg _ rep) = rep - ----------------------------------------------------------------------------- -- Register-use information for expressions and other types ----------------------------------------------------------------------------- @@ -404,241 +417,159 @@ foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as {-# INLINABLE foldRegsDefd #-} ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ -{- -Note [Overlapping global registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The backend might not faithfully implement the abstraction of the STG -machine with independent registers for different values of type -GlobalReg. Specifically, certain pairs of registers (r1, r2) may -overlap in the sense that a store to r1 invalidates the value in r2, -and vice versa. - -Currently this occurs only on the x86_64 architecture where FloatReg n -and DoubleReg n are assigned the same microarchitectural register, in -order to allow functions to receive more Float# or Double# arguments -in registers (as opposed to on the stack). +-- -------------------------------------------------------------------------- +-- Pretty-printing expressions +-- -------------------------------------------------------------------------- -There are no specific rules about which registers might overlap with -which other registers, but presumably it's safe to assume that nothing -will overlap with special registers like Sp or BaseReg. +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e + = case e of + CmmRegOff reg i -> + pprExpr platform (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType platform reg) + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e -Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap -on a particular platform. The instance Eq GlobalReg is syntactic -equality of STG registers and does not take overlap into -account. However it is still used in UserOfRegs/DefinerOfRegs and -there are likely still bugs there, beware! --} +-- Here's the precedence table from GHC.Cmm.Parser: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing - | XmmReg -- 128-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +-- %left '-' '+' +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e - | YmmReg -- 256-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing - | ZmmReg -- 512-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +-- %left '/' '*' '%' +pprExpr8 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CCCS -- Current cost-centre stack - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: - | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = + case e of + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep align + -> let align_mark = + case align of + NaturallyAligned -> empty + Unaligned -> text "^" + in ppr rep <> align_mark <> brackets (pdoc platform expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp platform mop args - -- Base offset for the register table, used for accessing registers - -- which do not have real registers assigned to them. This register - -- will only appear after we have expanded GlobalReg into memory accesses - -- (where necessary) in the native code generator. - | BaseReg +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y - -- The register used by the platform for the C stack pointer. This is - -- a break in the STG abstraction used exclusively to setup stack unwinding - -- information. - | MachSp + -- unary + [x] -> doc <> pprExpr9 platform x - -- The is a dummy register used to indicate to the stack unwinder where - -- a routine would return to. - | UnwindReturnReg + _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map (pprExpr platform) args))) + empty - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - deriving( Show ) + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing --- NOTE: this Ord instance affects the tuple layout in GHCi, see --- Note [GHCi tuple layout] -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT +-- -------------------------------------------------------------------------- +-- Pretty-printing literals +-- +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- -------------------------------------------------------------------------- --- convenient aliases -baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, - currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -hpLimReg = CmmGlobal HpLim -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node -currentTSOReg = CmmGlobal CurrentTSO -currentNurseryReg = CmmGlobal CurrentNursery -hpAllocReg = CmmGlobal HpAlloc -cccsReg = CmmGlobal CCCS +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth platform) $ + space <> dcolon <+> ppr rep ] -node :: GlobalReg -node = VanillaReg 1 VGcPtr + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' + CmmLabel clbl -> pdoc platform clbl + CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' + <> pdoc platform clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" -globalRegType :: Platform -> GlobalReg -> CmmType -globalRegType platform = \case - (VanillaReg _ VGcPtr) -> gcWord platform - (VanillaReg _ VNonGcPtr) -> bWord platform - (FloatReg _) -> cmmFloat W32 - (DoubleReg _) -> cmmFloat W64 - (LongReg _) -> cmmBits W64 - -- TODO: improve the internal model of SIMD/vectorized registers - -- the right design SHOULd improve handling of float and double code too. - -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim - (XmmReg _) -> cmmVec 4 (cmmBits W32) - (YmmReg _) -> cmmVec 8 (cmmBits W32) - (ZmmReg _) -> cmmVec 16 (cmmBits W32) +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit - Hp -> gcWord platform -- The initialiser for all - -- dynamically allocated closures - _ -> bWord platform +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) -isArgReg :: GlobalReg -> Bool -isArgReg (VanillaReg {}) = True -isArgReg (FloatReg {}) = True -isArgReg (DoubleReg {}) = True -isArgReg (LongReg {}) = True -isArgReg (XmmReg {}) = True -isArgReg (YmmReg {}) = True -isArgReg (ZmmReg {}) = True -isArgReg _ = False +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -66,7 +66,6 @@ | MO_S_Neg Width -- unary - -- Unsigned multiply/divide - | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) @@ -252,7 +251,6 @@ MO_Ne _ -> True MO_Mul _ -> True MO_S_MulMayOflo _ -> True - MO_U_MulMayOflo _ -> True MO_And _ -> True MO_Or _ -> True MO_Xor _ -> True @@ -380,7 +378,6 @@ MO_S_Quot r -> cmmBits r MO_S_Rem r -> cmmBits r MO_S_Neg r -> cmmBits r - MO_U_MulMayOflo r -> cmmBits r MO_U_Quot r -> cmmBits r MO_U_Rem r -> cmmBits r @@ -474,7 +471,6 @@ MO_S_Quot r -> [r,r] MO_S_Rem r -> [r,r] MO_S_Neg r -> [r] - MO_U_MulMayOflo r -> [r,r] MO_U_Quot r -> [r,r] MO_U_Rem r -> [r,r] diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} -- CmmNode type for representation using Hoopl graphs. @@ -28,23 +26,29 @@ import GHC.Prelude hiding (succ) import GHC.Platform.Regs +import GHC.Cmm.CLabel import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString +import GHC.Data.Pair import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Types.Tickish (CmmTickish) import qualified GHC.Types.Unique as U +import GHC.Types.Basic (FunctionOrData(..)) +import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label +import Data.Foldable (toList) +import Data.Functor.Classes (liftCompare) import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) -import GHC.Utils.Misc +import GHC.Utils.Constants (debugIsOn) ------------------------ @@ -165,6 +169,177 @@ intrbl:: Bool -- whether or not the call is interruptible } -> CmmNode O C +instance OutputableP Platform (CmmNode e x) where + pdoc = pprNode + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id tscope -> + (sdocOption sdocSuppressUniques $ \case + True -> text "_lbl_" + False -> ppr id + ) + <> colon + <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> ppUnlessOption sdocSuppressTicks + (text "//tick" <+> ppr t) + + -- unwind reg = expr; + CmmUnwind regs -> + text "unwind " + <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi + where + align_mark = case align of + Unaligned -> text "^" + NaturallyAligned -> empty + rep = ppr ( cmmExprType platform expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + text "call", + pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] + + -- goto label; + CmmBranch ident -> text "goto" <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f l -> + hsep [ text "if" + , parens (pdoc platform expr) + , case l of + Nothing -> empty + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" + , ppr t <> semi + , text "else goto" + , ppr f <> semi + ] + + CmmSwitch expr ids -> + hang (hsep [ text "switch" + , range + , if isTrivialCmmExpr expr + then pdoc platform expr + else parens (pdoc platform expr) + , text "{" + ]) + 4 (vcat (map ppCase cases) $$ def) $$ rbrace + where + (cases, mbdef) = switchTargetsFallThrough ids + ppCase (is,l) = hsep + [ text "case" + , commafy $ toList $ fmap integer is + , text ": goto" + , ppr l <> semi + ] + def | Just l <- mbdef = hsep + [ text "default:" + , braces (text "goto" <+> ppr l <> semi) + ] + | otherwise = empty + + range = brackets $ hsep [integer lo, text "..", integer hi] + where (lo,hi) = switchTargetsRange ids + + CmmCall tgt k regs out res updfr_off -> + hcat [ text "call", space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = pdoc platform f + pprFun f = parens (pdoc platform f) + + returns + | Just r <- k = text "returns to" <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , pdoc platform t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (pdoc platform as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs + +instance OutputableP Platform (Block CmmNode C C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode C O) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O O) where + pdoc = pprBlock + +instance OutputableP Platform (Graph CmmNode e x) where + pdoc = pprGraph + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pdoc platform + , ($$) . (nest 4) . pdoc platform + , ($$) . (nest 4) . pdoc platform + ) + block + empty + +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph platform = \case + GNil -> empty + GUnit block -> pdoc platform block + GMany entry body exit -> + text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: OutputableP Platform (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = pdoc platform block + {- Note [Foreign calls] ~~~~~~~~~~~~~~~~~~~~~~~ A CmmUnsafeForeignCall is used for *unsafe* foreign calls; @@ -291,11 +466,25 @@ CmmReturnInfo deriving Eq +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + data CmmReturnInfo = CmmMayReturn | CmmNeverReturns deriving ( Eq ) +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = text "never returns" + data ForeignTarget -- The target of a foreign call = ForeignTarget -- A foreign procedure CmmExpr -- Its address @@ -304,6 +493,35 @@ CallishMachOp -- Which one deriving Eq +instance OutputableP Platform ForeignTarget where + pdoc = pprForeignTarget + +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = + ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = pdoc platform t + ppr_target fn' = parens (pdoc platform fn') +pprForeignTarget platform (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = pdoc platform + (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction) + +instance Outputable Convention where + ppr = pprConvention + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + + foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target = ( res_hints ++ repeat NoHint @@ -505,7 +723,7 @@ mapExpM _ (CmmTick _) = Nothing mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e align) = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e] +mapExpM f (CmmStore addr e align) = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair addr e) mapExpM _ (CmmBranch _) = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e @@ -693,7 +911,7 @@ compare GlobalScope _ = LT compare _ GlobalScope = GT compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' - compare scope scope' = cmpList nonDetCmpUnique + compare scope scope' = liftCompare nonDetCmpUnique (sortBy nonDetCmpUnique $ scopeUniques scope) (sortBy nonDetCmpUnique $ scopeUniques scope') diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Cmm/Reg.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Cmm.Reg + ( -- * Cmm Registers + CmmReg(..) + , cmmRegType + , cmmRegWidth + -- * Local registers + , LocalReg(..) + , localRegType + -- * Global registers + , GlobalReg(..), isArgReg, globalRegType + , pprGlobalReg + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + , VGcPtr(..) + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Cmm.Type + +----------------------------------------------------------------------------- +-- Cmm registers +----------------------------------------------------------------------------- + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalReg + deriving( Eq, Ord, Show ) + +instance Outputable CmmReg where + ppr e = pprReg e + +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +cmmRegType :: Platform -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType platform (CmmGlobal reg) = globalRegType platform reg + +cmmRegWidth :: Platform -> CmmReg -> Width +cmmRegWidth platform = typeWidth . cmmRegType platform + + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique !CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + deriving Show + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) = +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + char '_' <> pprUnique uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + pprUnique unique = sdocOption sdocSuppressUniques $ \case + True -> text "_locVar_" + False -> ppr unique + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +{- +Note [Overlapping global registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) + +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register + | CCCS -- Current cost-centre stack + | CurrentTSO -- pointer to current thread's TSO + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun + + -- Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + -- The register used by the platform for the C stack pointer. This is + -- a break in the STG abstraction used exclusively to setup stack unwinding + -- information. + | MachSp + + -- The is a dummy register used to indicate to the stack unwinder where + -- a routine would return to. + | UnwindReturnReg + + -- Base Register for PIC (position-independent code) calculations + -- Only used inside the native code generator. It's exact meaning differs + -- from platform to platform (see module PositionIndependentCode). + | PicBaseReg + + deriving( Show ) + +instance Eq GlobalReg where + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + FloatReg i == FloatReg j = i==j + DoubleReg i == DoubleReg j = i==j + LongReg i == LongReg j = i==j + -- NOTE: XMM, YMM, ZMM registers actually are the same registers + -- at least with respect to store at YMM i and then read from XMM i + -- and similarly for ZMM etc. + XmmReg i == XmmReg j = i==j + YmmReg i == YmmReg j = i==j + ZmmReg i == ZmmReg j = i==j + Sp == Sp = True + SpLim == SpLim = True + Hp == Hp = True + HpLim == HpLim = True + CCCS == CCCS = True + CurrentTSO == CurrentTSO = True + CurrentNursery == CurrentNursery = True + HpAlloc == HpAlloc = True + EagerBlackholeInfo == EagerBlackholeInfo = True + GCEnter1 == GCEnter1 = True + GCFun == GCFun = True + BaseReg == BaseReg = True + MachSp == MachSp = True + UnwindReturnReg == UnwindReturnReg = True + PicBaseReg == PicBaseReg = True + _r1 == _r2 = False + +-- NOTE: this Ord instance affects the tuple layout in GHCi, see +-- Note [GHCi and native call registers] +instance Ord GlobalReg where + compare (VanillaReg i _) (VanillaReg j _) = compare i j + -- Ignore type when seeking clashes + compare (FloatReg i) (FloatReg j) = compare i j + compare (DoubleReg i) (DoubleReg j) = compare i j + compare (LongReg i) (LongReg j) = compare i j + compare (XmmReg i) (XmmReg j) = compare i j + compare (YmmReg i) (YmmReg j) = compare i j + compare (ZmmReg i) (ZmmReg j) = compare i j + compare Sp Sp = EQ + compare SpLim SpLim = EQ + compare Hp Hp = EQ + compare HpLim HpLim = EQ + compare CCCS CCCS = EQ + compare CurrentTSO CurrentTSO = EQ + compare CurrentNursery CurrentNursery = EQ + compare HpAlloc HpAlloc = EQ + compare EagerBlackholeInfo EagerBlackholeInfo = EQ + compare GCEnter1 GCEnter1 = EQ + compare GCFun GCFun = EQ + compare BaseReg BaseReg = EQ + compare MachSp MachSp = EQ + compare UnwindReturnReg UnwindReturnReg = EQ + compare PicBaseReg PicBaseReg = EQ + compare (VanillaReg _ _) _ = LT + compare _ (VanillaReg _ _) = GT + compare (FloatReg _) _ = LT + compare _ (FloatReg _) = GT + compare (DoubleReg _) _ = LT + compare _ (DoubleReg _) = GT + compare (LongReg _) _ = LT + compare _ (LongReg _) = GT + compare (XmmReg _) _ = LT + compare _ (XmmReg _) = GT + compare (YmmReg _) _ = LT + compare _ (YmmReg _) = GT + compare (ZmmReg _) _ = LT + compare _ (ZmmReg _) = GT + compare Sp _ = LT + compare _ Sp = GT + compare SpLim _ = LT + compare _ SpLim = GT + compare Hp _ = LT + compare _ Hp = GT + compare HpLim _ = LT + compare _ HpLim = GT + compare CCCS _ = LT + compare _ CCCS = GT + compare CurrentTSO _ = LT + compare _ CurrentTSO = GT + compare CurrentNursery _ = LT + compare _ CurrentNursery = GT + compare HpAlloc _ = LT + compare _ HpAlloc = GT + compare GCEnter1 _ = LT + compare _ GCEnter1 = GT + compare GCFun _ = LT + compare _ GCFun = GT + compare BaseReg _ = LT + compare _ BaseReg = GT + compare MachSp _ = LT + compare _ MachSp = GT + compare UnwindReturnReg _ = LT + compare _ UnwindReturnReg = GT + compare EagerBlackholeInfo _ = LT + compare _ EagerBlackholeInfo = GT + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +instance OutputableP env GlobalReg where + pdoc _ = ppr + +pprGlobalReg :: IsLine doc => GlobalReg -> doc +pprGlobalReg gr + = case gr of + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-} +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- convenient aliases +baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg +baseReg = CmmGlobal BaseReg +spReg = CmmGlobal Sp +hpReg = CmmGlobal Hp +hpLimReg = CmmGlobal HpLim +spLimReg = CmmGlobal SpLim +nodeReg = CmmGlobal node +currentTSOReg = CmmGlobal CurrentTSO +currentNurseryReg = CmmGlobal CurrentNursery +hpAllocReg = CmmGlobal HpAlloc +cccsReg = CmmGlobal CCCS + +node :: GlobalReg +node = VanillaReg 1 VGcPtr + +globalRegType :: Platform -> GlobalReg -> CmmType +globalRegType platform = \case + (VanillaReg _ VGcPtr) -> gcWord platform + (VanillaReg _ VNonGcPtr) -> bWord platform + (FloatReg _) -> cmmFloat W32 + (DoubleReg _) -> cmmFloat W64 + (LongReg _) -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers + -- the right design SHOULd improve handling of float and double code too. + -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim + (XmmReg _) -> cmmVec 4 (cmmBits W32) + (YmmReg _) -> cmmVec 8 (cmmBits W32) + (ZmmReg _) -> cmmVec 16 (cmmBits W32) + + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs --- a/compiler/GHC/Cmm/Switch.hs +++ b/compiler/GHC/Cmm/Switch.hs @@ -8,11 +8,11 @@ switchTargetsToList, eqSwitchTargetWith, SwitchPlan(..), - backendSupportsSwitch, + backendHasNativeSwitch, createSwitchPlan, ) where -import GHC.Prelude +import GHC.Prelude hiding (head) import GHC.Utils.Outputable import GHC.Driver.Backend @@ -20,8 +20,7 @@ import GHC.Cmm.Dataflow.Label (Label) import Data.Maybe -import Data.List (groupBy) -import Data.Function (on) +import Data.List.NonEmpty (NonEmpty (..), groupWith, head) import qualified Data.Map as M -- Note [Cmm Switches, the general plan] @@ -201,11 +200,11 @@ -- | Groups cases with equal targets, suitable for pretty-printing to a -- c-like switch statement with fall-through semantics. -switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) +switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label) switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) where - groups = map (\xs -> (map fst xs, snd (head xs))) $ - groupBy ((==) `on` snd) $ + groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $ + groupWith snd $ M.toList branches -- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim" @@ -312,13 +311,6 @@ -} --- | Does the backend support switch out of the box? Then leave this to the --- backend! -backendSupportsSwitch :: Backend -> Bool -backendSupportsSwitch ViaC = True -backendSupportsSwitch LLVM = True -backendSupportsSwitch _ = False - -- | This function creates a SwitchPlan from a SwitchTargets value, breaking it -- down into smaller pieces suitable for code generation. createSwitchPlan :: SwitchTargets -> SwitchPlan @@ -372,7 +364,7 @@ --- Step 3: Fill in the blanks --- --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every +-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer in between every -- two entries, dividing the range. -- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if -- the expression is < n, and plan2 otherwise. diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -364,6 +364,14 @@ -- Used to give extra per-argument or per-result -- information needed by foreign calling conventions +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + + ------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to diff --git a/compiler/GHC/CmmToLlvm/Config.hs b/compiler/GHC/CmmToLlvm/Config.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Config.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} + +-- | Llvm code generator configuration +module GHC.CmmToLlvm.Config + ( LlvmCgConfig(..) + , LlvmConfig(..) + , LlvmTarget(..) + , initLlvmConfig + -- * LLVM version + , LlvmVersion(..) + , supportedLlvmVersionLowerBound + , supportedLlvmVersionUpperBound + , parseLlvmVersion + , llvmVersionSupported + , llvmVersionStr + , llvmVersionList + ) +where + +#include "ghc-llvm-version.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Utils.Outputable +import GHC.Settings.Utils +import GHC.Utils.Panic + +import Data.Char (isDigit) +import Data.List (intercalate) +import qualified Data.List.NonEmpty as NE +import System.FilePath + +data LlvmCgConfig = LlvmCgConfig + { llvmCgPlatform :: !Platform -- ^ Target platform + , llvmCgContext :: !SDocContext -- ^ Context for LLVM code generation + , llvmCgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values + , llvmCgSplitSection :: !Bool -- ^ Split sections + , llvmCgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions + , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using + , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version + , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM + , llvmCgLlvmConfig :: !LlvmConfig -- ^ Supported LLVM configurations. + -- see Note [LLVM configuration] + } + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- + +initLlvmConfig :: FilePath -> IO LlvmConfig +initLlvmConfig top_dir + = do + targets <- readAndParse "llvm-targets" + passes <- readAndParse "llvm-passes" + return $ LlvmConfig + { llvmTargets = fmap mkLlvmTarget <$> targets + , llvmPasses = passes + } + where + readAndParse :: Read a => String -> IO a + readAndParse name = do + let f = top_dir name + llvmConfigStr <- readFile f + case maybeReadFuzzy llvmConfigStr of + Just s -> return s + Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + +data LlvmConfig = LlvmConfig + { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] + } + + +--------------------------------------------------------- +-- LLVM version +--------------------------------------------------------- + +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } + deriving (Eq, Ord) + +parseLlvmVersion :: String -> Maybe LlvmVersion +parseLlvmVersion = + fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s + +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) + +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported v = + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound + +llvmVersionStr :: LlvmVersion -> String +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -7,9 +7,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( -- * Main data types @@ -42,9 +39,11 @@ -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, - collectNBinders, + collectNBinders, collectNValBinders_maybe, collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectFunSimple, exprToType, wrapLamBody, @@ -64,7 +63,8 @@ maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isInlineUnfolding, isBootUnfolding, + isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, + isInlineUnfolding, isBootUnfolding, hasCoreUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, @@ -82,9 +82,8 @@ IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types - CoreRule(..), RuleBase, - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv, + CoreRule(..), + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, @@ -99,9 +98,9 @@ import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.Rules.Config ( RuleOpts ) import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Name.Env( NameEnv ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon @@ -175,7 +174,6 @@ -- * Primitive literals -- -- * Applications: note that the argument may be a 'Type'. --- See Note [Core let/app invariant] -- See Note [Representation polymorphism invariants] -- -- * Lambda abstraction @@ -186,7 +184,7 @@ -- bound and then executing the sub-expression. -- -- See Note [Core letrec invariant] --- See Note [Core let/app invariant] +-- See Note [Core let-can-float invariant] -- See Note [Representation polymorphism invariants] -- See Note [Core type and coercion invariant] -- @@ -383,6 +381,25 @@ For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +Note [Compilation plan for top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a summary on how top-level string literals are handled by various +parts of the compilation pipeline. + +* In the source language, there is no way to bind a primitive string literal + at the top level. + +* In Core, we have a special rule that permits top-level Addr# bindings. See + Note [Core top-level string literals]. Core-to-core passes may introduce + new top-level string literals. + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* A top-level string literal may end up exported from a module. In this case, + in the object file, the content of the exported literal is given a label with + the _bytes suffix. + Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The let-can-float invariant: @@ -479,47 +496,6 @@ in the object file, the content of the exported literal is given a label with the _bytes suffix. -Note [NON-BOTTOM-DICTS invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is a global invariant (not checkable by Lint) that - -This means that the let can be floated around -without difficulty. For example, this is OK: - - y::Int# = x +# 1# - -But this is not, as it may affect termination if the -expression is floated out: - - y::Int# = fac 4# - -In this situation you should use @case@ rather than a @let@. The function -'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or -alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly, -which will generate a @case@ if necessary - -The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in -GHC.Core.Make. - -* A superclass selection from some other dictionary. This is harder to guarantee: - see Note [Recursive superclasses] and Note [Solving superclass constraints] - in GHC.Tc.TyCl.Instance. - -A bad Core-to-Core pass could invalidate this reasoning, but that's too bad. -It's still an invariant of Core programs generated by GHC from Haskell, and -Core-to-Core passes maintain it. - -Why is it useful to know that dictionaries are non-bottom? - -1. It justifies the use of `-XDictsStrict`; - see `GHC.Core.Types.Demand.strictifyDictDmd` - -2. It means that (eq_sel d) is ok-for-speculation and thus - case (eq_sel d) of _ -> blah - can be discarded by the Simplifier. See these Notes: - Note [exprOkForSpeculation and type classes] in GHC.Core.Utils - Note[Speculative evaluation] in GHC.CoreToStg.Prep - Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions are one of the more complicated elements of the Core @@ -797,18 +773,18 @@ the binder. Reason: if we want to push a continuation into the RHS we must push it into the unfolding as well. - 2b. The Arity (in the IdInfo) of a join point is the number of value - binders in the top n lambdas, where n is the join arity. + 2b. The Arity (in the IdInfo) of a join point varies independently of the + join-arity. For example, we could have + j x = case x of { T -> \y.y; F -> \y.3 } + Its join-arity is 1, but its idArity is 2; and we do not eta-expand + join points: see Note [Do not eta-expand join points] in + GHC.Core.Opt.Simplify.Utils. - So arity <= join arity; the former counts only value binders - while the latter counts all binders. - e.g. Suppose $j has join arity 1 - let j = \x y. e in case x of { A -> j 1; B -> j 2 } - Then its ordinary arity is also 1, not 2. + Allowing the idArity to be bigger than the join-arity is + important in arityType; see GHC.Core.Opt.Arity + Note [Arity for recursive join bindings] - The arity of a join point isn't very important; but short of setting - it to zero, it is helpful to have an invariant. E.g. #17294. - See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. + Historical note: see #17294. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points. @@ -819,11 +795,11 @@ However, join points have simpler invariants in other ways 5. A join point can have an unboxed type without the RHS being - ok-for-speculation (i.e. drop the let/app invariant) + ok-for-speculation (i.e. drop the let-can-float invariant) e.g. let j :: Int# = factorial x in ... 6. The RHS of join point is not required to have a fixed runtime representation, - e.g. let j :: r :: TYPE l = fail void# in ... + e.g. let j :: r :: TYPE l = fail (##) in ... This happened in an intermediate program #13394 Examples: @@ -1111,6 +1087,12 @@ M. But it's painful, because it means we need to keep track of all the orphan modules below us. + * The "visible orphan modules" are all the orphan module in the transitive + closure of the imports of this module. + + * During instance lookup, we filter orphan instances depending on + whether or not the instance is in a visible orphan module. + * A non-orphan is not finger-printed separately. Instead, for fingerprinting purposes it is treated as part of the entity it mentions on the LHS. For example @@ -1125,12 +1107,20 @@ Orphan-hood is computed * For class instances: - when we make a ClsInst - (because it is needed during instance lookup) + when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance + (because it is needed during instance lookup) + See Note [When exactly is an instance decl an orphan?] + in GHC.Core.InstEnv - * For rules and family instances: - when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule) - or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) + * For rules + when we generate a CoreRule (GHC.Core.Rules.mkRule) + + * For family instances: + when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) + +Orphan-hood is persisted into interface files, in ClsInst, FamInst, +and CoreRules. + -} {- @@ -1145,50 +1135,7 @@ representation. -} --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] - -- The rules are unordered; - -- we sort out any overlaps on lookup --- | A full rule environment which we can apply rules from. Like a 'RuleBase', --- but it also includes the set of visible orphans we use to filter out orphan --- rules which are not visible (even though we can see them...) -data RuleEnv - = RuleEnv { re_base :: [RuleBase] -- See Note [Why re_base is a list] - , re_visible_orphs :: ModuleSet - } - -mkRuleEnv :: RuleBase -> [Module] -> RuleEnv -mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs) - -emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv [] emptyModuleSet - -{- -Note [Why re_base is a list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In Note [Overall plumbing for rules], it is explained that the final -RuleBase which we must consider is combined from 4 different sources. - -During simplifier runs, the fourth source of rules is constantly being updated -as new interfaces are loaded into the EPS. Therefore just before we check to see -if any rules match we get the EPS RuleBase and combine it with the existing RuleBase -and then perform exactly 1 lookup into the new map. - -It is more efficient to avoid combining the environments and store the uncombined -environments as we can instead perform 1 lookup into each environment and then combine -the results. - -Essentially we use the identity: - -> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) -> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 - -The latter being more efficient as we don't construct an intermediate -map. --} - -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the @@ -1203,7 +1150,7 @@ -- Rough-matching stuff -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule + ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side -- Proper-matching stuff @@ -1254,18 +1201,11 @@ } -- See Note [Extra args in the target] in GHC.Core.Rules --- | Rule options -data RuleOpts = RuleOpts - { roPlatform :: !Platform -- ^ Target platform - , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding - , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled - , roBignumRules :: !Bool -- ^ Enable rules for bignums - } +type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are -- currently in scope. See Note [The InScopeSet invariant]. -type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) +data InScopeEnv = ISE InScopeSet IdUnfoldingFun type IdUnfoldingFun = Id -> Unfolding -- A function that embodies how to unfold an Id if you need @@ -1389,36 +1329,6 @@ -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------- -data UnfoldingSource - = -- See also Note [Historical note: unfoldings for wrappers] - - InlineRhs -- The current rhs of the function - -- Replace uf_tmpl each time around - - | InlineStable -- From an INLINE or INLINABLE pragma - -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever - -- (well, technically an INLINABLE might be made - -- UnfWhen if it was small enough, and then - -- it will behave like INLINE outside the current - -- module, but that is the way automatic unfoldings - -- work so it is consistent with the intended - -- meaning of INLINABLE). - -- - -- uf_tmpl may change, but only as a result of - -- gentle simplification, it doesn't get updated - -- to the current RHS during compilation as with - -- InlineRhs. - -- - -- See Note [InlineStable] - - | InlineCompulsory -- Something that *has* no binding, so you *must* inline it - -- Only a few primop-like things have this property - -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). - -- Inline absolutely always, however boring the context. - - -- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template. -- See Note [UnfoldingCache] data UnfoldingCache @@ -1555,18 +1465,12 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon -isStableSource :: UnfoldingSource -> Bool --- Keep the unfolding template -isStableSource InlineCompulsory = True -isStableSource InlineStable = True -isStableSource InlineRhs = False - -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl -- | Retrieves the template of an unfolding if possible --- maybeUnfoldingTemplate is used mainly wnen specialising, and we do +-- maybeUnfoldingTemplate is used mainly when specialising, and we do -- want to specialise DFuns, so it's important to return a template -- for DFunUnfoldings maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr @@ -1588,6 +1492,7 @@ isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isValueUnfolding (DFunUnfolding {}) = True isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will @@ -1595,9 +1500,10 @@ -- for 'OtherCon' isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (DFunUnfolding {}) = True isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache -isEvaldUnfolding _ = False +isEvaldUnfolding _ = False -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' @@ -1625,8 +1531,8 @@ expandUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True -isCompulsoryUnfolding _ = False +isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src +isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten @@ -1635,6 +1541,16 @@ isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False +isStableUserUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src +isStableUserUnfolding _ = False + +isStableSystemUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src +isStableSystemUnfolding _ = False + isInlineUnfolding :: Unfolding -> Bool -- ^ True of a /stable/ unfolding that is -- (a) always inlined; that is, with an `UnfWhen` guidance, or @@ -1691,8 +1607,8 @@ We consider even a StableUnfolding as fragile, because it needs substitution. -Note [InlineStable] -~~~~~~~~~~~~~~~~~ +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ When you say {-# INLINE f #-} f x = @@ -1702,10 +1618,11 @@ leaving the original unfolding intact in Unfolding of 'f'. For example all xs = foldr (&&) True xs any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the InlineRule saying "all . map p", -which deforests well at the call site. +We optimise any's RHS fully, but leave the stable unfolding for `any` +saying "all . map p", which deforests well at the call site. -So INLINE pragma gives rise to an InlineRule, which captures the original RHS. +So INLINE pragma gives rise to a stable unfolding, which captures the +original RHS. Moreover, it's only used when 'f' is applied to the specified number of arguments; that is, the number of argument on @@ -1719,9 +1636,6 @@ it'd only inline when applied to three arguments. This slightly-experimental change was requested by Roman, but it seems to make sense. -See also Note [Inlining an InlineRule] in GHC.Core.Unfold. - - Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In unfoldings and rules, we guarantee that the template is occ-analysed, @@ -1953,8 +1867,8 @@ mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes --- that the rhs satisfies the let/app invariant. Prefer to use 'GHC.Core.Make.mkCoreLets' if --- possible, which does guarantee the invariant +-- that the rhs satisfies the let-can-float invariant. Prefer to use +-- 'GHC.Core.Make.mkCoreLets' if possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'GHC.Core.Make.mkCoreLams' if possible @@ -2036,6 +1950,21 @@ bindersOfBinds :: [Bind b] -> [b] bindersOfBinds binds = foldr ((++) . bindersOf) [] binds +-- We inline this to avoid unknown function calls. +{-# INLINE foldBindersOfBindStrict #-} +foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a +foldBindersOfBindStrict f + = \z bind -> case bind of + NonRec b _rhs -> f z b + Rec pairs -> foldl' f z $ map fst pairs + +{-# INLINE foldBindersOfBindsStrict #-} +foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a +foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds + where + fold_bind = (foldBindersOfBindStrict f) + + rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] @@ -2057,10 +1986,12 @@ collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) collectValBinders :: CoreExpr -> ([Id], CoreExpr) collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) --- | Strip off exactly N leading lambdas (type or value). Good for use with --- join points. -collectNBinders :: Int -> Expr b -> ([b], Expr b) +-- | Strip off exactly N leading lambdas (type or value). +-- Good for use with join points. +-- Panic if there aren't enough +collectNBinders :: JoinArity -> Expr b -> ([b], Expr b) + collectBinders expr = go [] expr where @@ -2092,6 +2023,18 @@ go n bs (Lam b e) = go (n-1) (b:bs) e go _ _ _ = pprPanic "collectNBinders" $ int orig_n +-- | Strip off exactly N leading value lambdas +-- returning all the binders found up to that point +-- Return Nothing if there aren't enough +collectNValBinders_maybe :: Arity -> CoreExpr -> Maybe ([Var], CoreExpr) +collectNValBinders_maybe orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = Just (reverse bs, expr) + go n bs (Lam b e) | isId b = go (n-1) (b:bs) e + | otherwise = go n (b:bs) e + go _ _ _ = Nothing + -- | Takes a nested application expression and returns the function -- being applied and the arguments to which it is applied collectArgs :: Expr b -> (Expr b, [Arg b]) @@ -2100,6 +2043,19 @@ where go (App f a) as = go f (a:as) go e as = (e, as) + +-- | Takes a nested application expression and returns the function +-- being applied. Looking through casts and ticks to find it. +collectFunSimple :: Expr b -> Expr b +collectFunSimple expr + = go expr + where + go expr' = + case expr' of + App f _a -> go f + Tick _t e -> go e + Cast e _co -> go e + e -> e -- | fmap on the body of a lambda. -- wrapLamBody f (\x -> body) == (\x -> f body) diff --git a/compiler/GHC/Core.hs-boot b/compiler/GHC/Core.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core.hs-boot @@ -0,0 +1,8 @@ +module GHC.Core where +import {-# SOURCE #-} GHC.Types.Var + +data Expr a + +type CoreBndr = Var + +type CoreExpr = Expr CoreBndr diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,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(..), @@ -34,8 +37,10 @@ mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, - mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo, + mkSelCo, getNthFun, getNthFromType, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, + mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo, + mkNakedFunCo1, mkNakedFunCo2, mkForAllCo, mkForAllCos, mkHomoForAllCos, mkPhantomCo, mkHoleCo, mkUnivCo, mkSubCo, @@ -44,28 +49,24 @@ mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, mkKindCo, castCoercionKind, castCoercionKind1, castCoercionKind2, - mkFamilyTyConAppCo, - mkHeteroCoercionType, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- ** Decomposition instNewTyCon_maybe, - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, + NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, topNormaliseNewType_maybe, topNormaliseTypeX, decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, - splitTyConAppCo_maybe, splitAppCo_maybe, splitFunCo_maybe, splitForAllCo_maybe, splitForAllCo_ty_maybe, splitForAllCo_co_maybe, - nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - + tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + tyConRoleListX, tyConRoleListRepresentational, funRole, pickLR, isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, @@ -78,7 +79,6 @@ -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - isCoVar_maybe, -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, @@ -98,7 +98,7 @@ liftCoSubstVarBndrUsing, isMappedByLC, mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, @@ -121,7 +121,7 @@ -- * Other promoteCoercion, buildCoercion, - multToCo, + multToCo, mkRuntimeRepCo, hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, @@ -138,17 +138,18 @@ import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom -import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) import GHC.Types.Basic import GHC.Types.Unique +import GHC.Data.FastString import GHC.Data.Pair import GHC.Types.SrcLoc import GHC.Builtin.Names @@ -156,6 +157,8 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf import GHC.Utils.Misc import GHC.Utils.Outputable @@ -248,7 +251,7 @@ -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + [ pprUserForAll (mkForAllTyBinders Inferred bndrs') -- See Note [Printing foralls in type family instances] in GHC.Iface.Type , pp_lhs <+> ppr_rhs tidy_env ee_rhs , vcat [ text "-- Defined" <+> pp_loc @@ -293,7 +296,7 @@ (env', bndr') = tidyVarBndr env bndr env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOcc "_") + tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) -- Tidy the binder to "_" is_wildcard :: Var -> Bool @@ -311,7 +314,7 @@ coToMCo :: Coercion -> MCoercion -- Convert a coercion to a MCoercion, -- It's not clear whether or not isReflexiveCo would be better here --- See #19815 for a bit of data and dicussion on this point +-- See #19815 for a bit of data and discussion on this point coToMCo co | isReflCo co = MRefl | otherwise = MCo co @@ -366,9 +369,9 @@ mkPiMCos _ MRefl = MRefl mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) -mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR +mkFunResMCo :: Id -> MCoercionR -> MCoercionR mkFunResMCo _ MRefl = MRefl -mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty co) +mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl = mkReflCo r ty @@ -393,48 +396,35 @@ Destructing coercions %* * %************************************************************************ - -Note [Function coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Remember that - (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep -whose `RuntimeRep' arguments are intentionally marked inferred to -avoid type application. - -Hence - FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2) -is short for - TyConAppCo (->) mult co_rep1 co_rep2 co1 co2 -where co_rep1, co_rep2 are the coercions on the representations. -} - -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: -- -- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] decomposeCo :: Arity -> Coercion - -> [Role] -- the roles of the output coercions - -- this must have at least as many - -- entries as the Arity provided + -> Infinite Role -- the roles of the output coercions -> [Coercion] decomposeCo arity co rs - = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] - -- Remember, Nth is zero-indexed + = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ] + -- Remember, SelTyCon is zero-indexed decomposeFunCo :: HasDebugCallStack - => Role -- Role of the input coercion - -> Coercion -- Input coercion + => Coercion -- Input coercion -> (CoercionN, Coercion, Coercion) --- Expects co :: (s1 -> t1) ~ (s2 -> t2) --- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "3" and "4" +-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2) +-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2) +-- actually cow will be a Phantom coercion if the input is a Phantom coercion -decomposeFunCo _ (FunCo _ w co1 co2) = (w, co1, co2) - -- Short-circuits the calls to mkNthCo +decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) + = (w, co1, co2) + -- Short-circuits the calls to mkSelCo -decomposeFunCo r co = assertPpr all_ok (ppr co) - (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) +decomposeFunCo co + = assertPpr all_ok (ppr co) $ + ( mkSelCo (SelFun SelMult) co + , mkSelCo (SelFun SelArg) co + , mkSelCo (SelFun SelRes) co ) where Pair s1t1 s2t2 = coercionKind co all_ok = isFunTy s1t1 && isFunTy s2t2 @@ -474,13 +464,13 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args where - orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + orig_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (TCvSubst,Kind) -- Lhs kind of coercion + -> (Subst,Kind) -- Lhs kind of coercion -> CoercionN -- coercion originally applied to the function - -> (TCvSubst,Kind) -- Rhs kind of coercion + -> (Subst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion) -- Invariant: co :: subst1(k1) ~ subst2(k2) @@ -495,55 +485,45 @@ -- 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 | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) - = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) co - (zapTCvSubst subst2, substTy subst1 k2) + (zapSubst subst2, substTy subst1 k2) (ty:tys) -- tys might not be empty, if the left-hand type of the original coercion -- didn't have enough binders go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) --- | Attempts to obtain the type variable underlying a 'Coercion' +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) 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 (tyConRolesX r tc) tys - ; return (tc, args) } -splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos) - where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] -splitTyConAppCo_maybe _ = Nothing - multToCo :: Mult -> Coercion multToCo r = mkNomReflCo r @@ -556,10 +536,10 @@ , Just (args', arg') <- snocView args = Just ( mkTyConAppCo r tc args', arg' ) - | not (mustBeSaturated tc) + | not (tyConMustBeSaturated tc) -- Never create unsaturated type family apps! , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg' = Just ( mkTyConAppCo r tc args', arg'' ) -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl @@ -572,7 +552,7 @@ -- Only used in specialise/Rules splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res) +splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) splitFunCo_maybe _ = Nothing splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) @@ -632,15 +612,41 @@ | otherwise = pprPanic "eqTyConRole: unknown tycon" (ppr tc) --- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, --- produce a coercion @rep_co :: r1 ~ r2@. +-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)` +-- produce a coercion `rep_co :: r1 ~ r2` +-- But actually it is possible that +-- co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: TYPE r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2) +-- See Note [mkRuntimeRepCo] mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion mkRuntimeRepCo co - = mkNthCo Nominal 0 kind_co + = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $ + mkSelCo (SelTyCon 0 Nominal) kind_co where kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - -- (up to silliness with Constraint) + Pair k1 k2 = coercionKind kind_co +{- Note [mkRuntimeRepCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +Given + class C a where { op :: Maybe a } +we will get an axiom + axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2) +(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.) + +Then we may call mkRuntimeRepCo on (axC ty), and that will return + mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2 + +So mkSelCo needs to be happy with decomposing a coercion of kind + CONSTRAINT r1 ~ TYPE r2 + +Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call` +in `mkSelCo`. See #23018 for a concrete example. (In this context it's +important that TYPE and CONSTRAINT have the same arity and kind, not +merely that they are not-apart; otherwise SelCo would not make sense.) +-} + isReflCoVar_maybe :: Var -> Maybe Coercion -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) -- Works on all kinds of Vars, not just CoVars @@ -712,7 +718,6 @@ Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - There are a plethora of functions for twiddling roles: mkSubCo: Requires a nominal input coercion and always produces a @@ -778,15 +783,11 @@ -- caller's responsibility to get the roles correct on argument coercions. mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos - | [w, _rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] - , isFunTyCon tc - = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) - -- rep1 :: ra ~ rc rep2 :: rb ~ rd - -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r w co1 co2 + | Just co <- tyConAppFunCo_maybe r tc cos + = co - -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + -- 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 | Just tys_roles <- traverse isReflCo_maybe cos @@ -795,17 +796,86 @@ | otherwise = TyConAppCo r tc cos +mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo takes no FunTyFlags; it works them out +mkFunCoNoFTF r w arg_co res_co + = mkFunCo2 r afl afr w arg_co res_co + where + afl = chooseFunTyFlag argl_ty resl_ty + afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + -- | Build a function 'Coercion' from two other 'Coercion's. That is, --- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. -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 (mkVisFunTy w ty1 ty2) - | otherwise = FunCo r w co1 co2 +-- 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@. +-- This (most common) version takes a single FunTyFlag, which is used +-- for both fco_afl and ftf_afr of the FunCo +mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo1 r af w arg_co res_co + = mkFunCo2 r af af w arg_co res_co +mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo1 does not check FunCo invariants (checkFunCo) +-- It is called during typechecking on un-zonked types; +-- in particular there may be un-zonked coercion variables. +mkNakedFunCo1 r af w arg_co res_co + = mkNakedFunCo2 r af af w arg_co res_co + +mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion -> Coercion +-- This is the smart constructor for FunCo; it checks invariants +mkFunCo2 r afl afr w arg_co res_co + = assertPprMaybe (checkFunCo r afl afr w arg_co res_co) $ + mkNakedFunCo2 r afl afr w arg_co res_co + +mkNakedFunCo2 :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion -> Coercion +-- This is the smart constructor for FunCo +-- "Naked"; it does not check invariants +mkNakedFunCo2 r afl afr w arg_co res_co + | Just (ty1, _) <- isReflCo_maybe arg_co + , Just (ty2, _) <- isReflCo_maybe res_co + , Just (w, _) <- isReflCo_maybe w + = mkReflCo r (mkFunTy afl w ty1 ty2) -- See Note [Refl invariant] + + | otherwise + = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = w, fco_arg = arg_co, fco_res = res_co } + + +checkFunCo :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion + -> Maybe SDoc +-- Checks well-formed-ness for FunCo +-- Used only in assertions and Lint +{-# NOINLINE checkFunCo #-} +checkFunCo _r afl afr _w arg_co res_co + | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty) + = Just (hang (text "Bad arg or res types") 2 pp_inputs) + + | afl == computed_afl + , afr == computed_afr + = Nothing + | otherwise + = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl + , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr + , pp_inputs ]) + where + computed_afl = chooseFunTyFlag argl_ty resl_ty + computed_afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + + pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty + , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty + , text "arg_co:" <+> ppr arg_co + , text "res_co:" <+> ppr res_co ] + + ok ty = isTYPEorCONSTRAINT (typeKind ty) + pp_ty str ty = text str <> colon <+> hang (ppr ty) + 2 (dcolon <+> ppr (typeKind ty)) + -- | Apply a 'Coercion' to another 'Coercion'. -- The second coercion must be Nominal, unless the first is Phantom. -- If the first is Phantom, then the second can be either Phantom or Nominal. @@ -822,15 +892,14 @@ -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) where - zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + zip_roles (Inf r1 _) [] = [downgradeRole r1 Nominal arg] + zip_roles (Inf r1 rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys mkAppCo (TyConAppCo r tc args) arg = case r of Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) Representational -> mkTyConAppCo Representational tc (args ++ [arg']) - where new_role = (tyConRolesRepresentational tc) !! (length args) + where new_role = tyConRolesRepresentational tc Inf.!! length args arg' = downgradeRole new_role Nominal arg Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) mkAppCo co arg = AppCo co arg @@ -878,7 +947,7 @@ Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst function might create an invalid coercion. Because a violation of the restriction might lead to a program that "goes wrong", it is checked all the time, -even in a production compiler and without -dcore-list. We *have* proved that the +even in a production compiler and without -dcore-lint. We *have* proved that the problem does not occur with homogeneous equality, so this check can be dropped once ~# is made to be homogeneous. -} @@ -889,7 +958,7 @@ -- See Note [Unused coercion variable in ForAllCo] mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo v kind_co co - | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True + | assert (varType v `eqType` (coercionLKind kind_co)) True , assert (isTyVar v || almostDevoidCoVarOfCo v co) True , Just (ty, r) <- isReflCo_maybe co , isGReflCo kind_co @@ -902,12 +971,12 @@ -- The kind of the tycovar should be the left-hand kind of the kind coercion. mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo_NoRefl v kind_co co - | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True - , assert (isTyVar v || almostDevoidCoVarOfCo v co) True + | assert (varType v `eqType` (coercionLKind kind_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 @@ -957,16 +1026,9 @@ optCoercion. Not a big deal either way. -} --- | Extract a covar, if possible. This check is dirty. Be ashamed --- of yourself. (It's dirty because it cares about the structure of --- a coercion, which is morally reprehensible.) -isCoVar_maybe :: Coercion -> Maybe CoVar -isCoVar_maybe (CoVarCo cv) = Just cv -isCoVar_maybe _ = Nothing - mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Coercion --- mkAxInstCo can legitimately be called over-staturated; +-- mkAxInstCo can legitimately be called over-saturated; -- i.e. with more type arguments than the coercion requires mkAxInstCo role ax index tys cos | arity == n_tys = downgradeRole role ax_role $ @@ -1075,142 +1137,85 @@ = GRefl r t1 (MCo $ mkTransCo co1 co2) mkTransCo co1 co2 = TransCo co1 co2 -mkNthCo :: HasDebugCallStack - => Role -- The role of the coercion you're creating - -> Int -- Zero-indexed +mkSelCo :: HasDebugCallStack + => CoSel -> Coercion -> Coercion -mkNthCo r n co - = assertPpr good_call bad_call_msg $ - go n co +mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co + +mkSelCo_maybe :: HasDebugCallStack + => CoSel + -> Coercion + -> Maybe Coercion +-- mkSelCo_maybe tries to optimise call to mkSelCo +mkSelCo_maybe cs co + = assertPpr (good_call cs) bad_call_msg $ + go cs co where Pair ty1 ty2 = coercionKind co - go 0 co - | Just (ty, _) <- isReflCo_maybe co - , Just (tv, _) <- splitForAllTyCoVar_maybe ty - = -- works for both tyvar and covar - assert (r == Nominal) $ - mkNomReflCo (varType tv) - - go n co - | Just (ty, r0) <- isReflCo_maybe co - , let tc = tyConAppTyCon ty - = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $ - assert (nthRole r0 tc n == r) $ - mkReflCo r (tyConAppArgN n ty) - where ok_tc_app :: Type -> Int -> Bool - ok_tc_app ty n - | Just (_, tys) <- splitTyConApp_maybe ty - = tys `lengthExceeds` n - | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall - = n == 0 - | otherwise - = False + go cs co + | Just (ty, r) <- isReflCo_maybe co + = Just (mkReflCo r (getNthFromType cs ty)) - go 0 (ForAllCo _ kind_co _) - = assert (r == Nominal) - kind_co + go SelForAll (ForAllCo _ kind_co _) + = Just kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth 0 co :: k1 ~N k2) + -- then (nth SelForAll co :: k1 ~N k2) -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) - -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) - go n (FunCo _ w arg res) - = mkNthCoFunCo n w arg res + go (SelFun fs) (FunCo _ _ _ w arg res) + = Just (getNthFun fs w arg res) - go n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n) - (vcat [ ppr tc - , ppr arg_cos - , ppr r0 - , ppr n - , ppr r ]) $ - arg_cos `getNth` n + go (SelTyCon i r) (TyConAppCo r0 tc arg_cos) + = assertPpr (r == tyConRole r0 tc i) + (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $ + Just (arg_cos `getNth` i) - go n (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo - = mkSymCo (go n co) + go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo + = do { co' <- go cs co; return (mkSymCo co') } - go n co - = NthCo r n co + go _ _ = Nothing -- Assertion checking bad_call_msg = vcat [ text "Coercion =" <+> ppr co , text "LHS ty =" <+> ppr ty1 , text "RHS ty =" <+> ppr ty2 - , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "cs =" <+> ppr cs , text "coercion role =" <+> ppr (coercionRole co) ] - good_call - -- If the Coercion passed in is between forall-types, then the Int must - -- be 0 and the role must be Nominal. + + -- good_call checks the typing rules given in Note [SelCo] + good_call SelForAll | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 - = n == 0 && r == Nominal - - -- If the Coercion passed in is between T tys and T tys', then the Int - -- must be less than the length of tys/tys' (which must be the same - -- lengths). - -- - -- If the role of the Coercion is nominal, then the role passed in must - -- be nominal. If the role of the Coercion is representational, then the - -- role passed in must be tyConRolesRepresentational T !! n. If the role - -- of the Coercion is Phantom, then the role passed in must be Phantom. - -- - -- See also Note [NthCo Cached Roles] if you're wondering why it's - -- blaringly obvious that we should be *computing* this role instead of - -- passing it in. - | Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - = let len1 = length tys1 - len2 = length tys2 - good_role = case coercionRole co of - Nominal -> r == Nominal - Representational -> r == (tyConRolesRepresentational tc1 !! n) - Phantom -> r == Phantom - in len1 == len2 && n < len1 && good_role - - | otherwise - = True - --- | Extract the nth field of a FunCo -mkNthCoFunCo :: Int -- ^ "n" - -> CoercionN -- ^ multiplicity coercion - -> Coercion -- ^ argument coercion - -> Coercion -- ^ result coercion - -> Coercion -- ^ nth coercion from a FunCo --- See Note [Function coercions] --- If FunCo _ mult arg_co res_co :: (s1:TYPE sk1 :mult-> s2:TYPE sk2) --- ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2) --- Then we want to behave as if co was --- TyConAppCo mult argk_co resk_co arg_co res_co --- where --- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) --- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) --- i.e. mkRuntimeRepCo -mkNthCoFunCo n w co1 co2 = case n of - 0 -> w - 1 -> mkRuntimeRepCo co1 - 2 -> mkRuntimeRepCo co2 - 3 -> co1 - 4 -> co2 - _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr w $$ ppr co1 $$ ppr co2) + = True --- | If you're about to call @mkNthCo r n co@, then @r@ should be --- whatever @nthCoRole n co@ returns. -nthCoRole :: Int -> Coercion -> Role -nthCoRole n co - | Just (tc, _) <- splitTyConApp_maybe lty - = nthRole r tc n + good_call (SelFun {}) + = isFunTy ty1 && isFunTy ty2 - | Just _ <- splitForAllTyCoVar_maybe lty - = Nominal + good_call (SelTyCon n r) + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , let { len1 = length tys1 + ; len2 = length tys2 } + = (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2)) + -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo] + && 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 @@ -1220,7 +1225,7 @@ = LRCo lr co -- | Instantiates a 'Coercion'. -mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo :: Coercion -> CoercionN -> Coercion mkInstCo (ForAllCo tcv _kind_co body_co) co | Just (arg, _) <- isReflCo_maybe co -- works for both tyvar and covar @@ -1236,7 +1241,7 @@ -- instead of @isReflCo@ | otherwise = GRefl r ty (MCo co) --- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, -- produces @co' :: (ty |> co) ~r ty@ mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion mkGReflLeftCo r ty co @@ -1288,10 +1293,10 @@ mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal w arg res) - = FunCo Representational w - (downgradeRole Representational Nominal arg) - (downgradeRole Representational Nominal res) +mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res }) + = co { fco_role = Representational + , fco_arg = downgradeRole Representational Nominal arg + , fco_res = downgradeRole Representational Nominal res } mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ SubCo co @@ -1359,12 +1364,13 @@ setNominalRole_maybe_helper co@(Refl _) = Just co setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co setNominalRole_maybe_helper (TyConAppCo Representational tc cos) - = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos + = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper (FunCo Representational w co1 co2) + setNominalRole_maybe_helper co@(FunCo { fco_role = Representational + , fco_arg = co1, fco_res = co2 }) = do { co1' <- setNominalRole_maybe Representational co1 ; co2' <- setNominalRole_maybe Representational co2 - ; return $ FunCo Nominal w co1' co2' + ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' } } setNominalRole_maybe_helper (SymCo co) = SymCo <$> setNominalRole_maybe_helper co @@ -1374,10 +1380,10 @@ = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 setNominalRole_maybe_helper (ForAllCo tv kind_co co) = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (NthCo _r n co) + setNominalRole_maybe_helper (SelCo n co) -- NB, this case recurses via setNominalRole_maybe, not -- setNominalRole_maybe_helper! - = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + = SelCo n <$> setNominalRole_maybe (coercionRole co) co setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg setNominalRole_maybe_helper (UnivCo prov _ co1 co2) @@ -1403,28 +1409,44 @@ -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles tc cos - = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos +applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational --- the Role parameter is the Role of the TyConAppCo +-- The Role parameter is the Role of the TyConAppCo -- defined here because this is intimately concerned with the implementation -- of TyConAppCo -- Always returns an infinite list (with a infinite tail of Nominal) -tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX :: Role -> TyCon -> Infinite Role tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = repeat role +tyConRolesX role _ = Inf.repeat role +tyConRoleListX :: Role -> TyCon -> [Role] +tyConRoleListX role = Inf.toList . tyConRolesX role + -- Returns the roles of the parameters of a tycon, with an infinite tail -- of Nominal -tyConRolesRepresentational :: TyCon -> [Role] -tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal +tyConRolesRepresentational :: TyCon -> Infinite Role +tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n - = (tyConRolesRepresentational tc) `getNth` n +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRoleListRepresentational :: TyCon -> [Role] +tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational +tyConRole :: Role -> TyCon -> Int -> Role +tyConRole Nominal _ _ = Nominal +tyConRole Phantom _ _ = Phantom +tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n + +funRole :: Role -> FunSel -> Role +funRole Nominal _ = Nominal +funRole Phantom _ = Phantom +funRole Representational fs = funRoleRepresentational fs + +funRoleRepresentational :: FunSel -> Role +funRoleRepresentational SelMult = Nominal +funRoleRepresentational SelArg = Representational +funRoleRepresentational SelRes = Representational + ltRole :: Role -> Role -> Bool -- Is one role "less" than another? -- Nominal < Representational < Phantom @@ -1443,20 +1465,18 @@ -- First cases handles anything that should yield refl. promoteCoercion co = case co of - _ | ki1 `eqType` ki2 - -> mkNomReflCo (typeKind ty1) - -- no later branch should return refl - -- The assert (False )s throughout - -- are these cases explicitly, but they should never fire. - - Refl _ -> assert False $ - mkNomReflCo ki1 + Refl _ -> mkNomReflCo ki1 - GRefl _ _ MRefl -> assert False $ - mkNomReflCo ki1 + GRefl _ _ MRefl -> mkNomReflCo ki1 GRefl _ _ (MCo co) -> co + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- No later branch should return refl + -- The assert (False )s throughout + -- are these cases explicitly, but they should never fire. + TyConAppCo _ tc args | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args -> co' @@ -1474,14 +1494,19 @@ | isTyVar tv -> promoteCoercion g - ForAllCo _ _ _ + ForAllCo {} -> assert False $ + -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2) + -- The tyvar case is handled above, so the bound var is a + -- a coercion variable. So both sides have kind Type + -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep). + -- So the result is Refl, and that should have been caught by + -- the first equation above mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - FunCo _ _ _ _ - -> assert False $ - mkNomReflCo liftedTypeKind + FunCo {} -> mkKindCo co + -- We can get Type~Constraint or Constraint~Type + -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint)) CoVarCo {} -> mkKindCo co HoleCo {} -> mkKindCo co @@ -1499,14 +1524,9 @@ TransCo co1 co2 -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - NthCo _ n co1 - | Just (_, args) <- splitTyConAppCo_maybe co1 - , args `lengthExceeds` n - -> promoteCoercion (args !! n) - - | Just _ <- splitForAllCo_maybe co - , n == 0 - -> assert False $ mkNomReflCo liftedTypeKind + SelCo n co1 + | Just co' <- mkSelCo_maybe n co1 + -> promoteCoercion co' | otherwise -> mkKindCo co @@ -1530,7 +1550,7 @@ -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep KindCo _ - -> assert False $ + -> assert False $ -- See the first equation above mkNomReflCo liftedTypeKind SubCo g @@ -1558,10 +1578,12 @@ -- w :: s1 ~ s2 -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty -- g :: (t1 -> t2) ~ (t3 -> t4) -- returns t2 ~ t4 - = Just $ mkNthCo Nominal 4 g -- extract result type, which is the 5th argument to (->) + = Just $ mkSelCo (SelFun SelRes) g -- extract result type + | otherwise -- one forall, one funty... = Nothing @@ -1617,29 +1639,6 @@ where (Pair t1 t2, r) = coercionKindRole g -mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN --- ^ Given a family instance 'TyCon' and its arg 'Coercion's, return the --- corresponding family 'Coercion'. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance 'TyCon' is :RTL, so: --- --- > mkFamilyTyConAppCo :RTL (co :: a ~# Int) = T (Maybe a) ~# T (Maybe Int) --- --- cf. 'mkFamilyTyConApp' -mkFamilyTyConAppCo tc cos - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $ - map (liftCoSubstWith Nominal tvs cos) fam_tys - = mkTyConAppCo Nominal fam_tc fam_cos - | otherwise - = mkTyConAppCo Nominal tc cos - --- See Note [Newtype coercions] in GHC.Core.TyCon - mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs @@ -1649,21 +1648,22 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $ -- We didn't call mkForAllCo here because if v does not appear - -- in co, the argement coercion will be nominal. But here we + -- in co, the argument coercion will be nominal. But here we -- 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 @@ -1746,18 +1746,13 @@ | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; -- ^ ev is evidence; -- Usually a co :: old type ~ new type + deriving (Functor) instance Outputable ev => Outputable (NormaliseStepResult ev) where ppr NS_Done = text "NS_Done" ppr NS_Abort = text "NS_Abort" ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - -- | Try one stepper and then try the next, if the first doesn't make -- progress. -- So if it returns NS_Done, it means that both steppers are satisfied @@ -1823,7 +1818,7 @@ -- -- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- --- then (a) @co : ty ~ ty'@. +-- then (a) @co : ty ~R ty'@. -- (b) ty' is not a newtype. -- -- The function returns @Nothing@ for non-@newtypes@, @@ -1874,7 +1869,7 @@ We want to push the coercion inside the constructor application. So we do this - g' :: t1~t2 = Nth 0 g + g' :: t1~t2 = SelCo (SelTyCon 0) g case K @t2 (x |> g' -> Maybe g') of K (y:t2 -> Maybe t2) -> rhs @@ -1891,7 +1886,7 @@ Note [extendLiftingContextEx] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider we have datatype - K :: \/k. \/a::k. P -> T k -- P be some type + K :: /\k. /\a::k. P -> T k -- P be some type g :: T k1 ~ T k2 case (K @k1 @t1 x) |> g of @@ -1899,7 +1894,7 @@ We want to push the coercion inside the constructor application. We first get the coercion mapped by the universal type variable k: - lc = k |-> Nth 0 g :: k1~k2 + lc = k |-> SelCo (SelTyCon 0) g :: k1~k2 Here, the important point is that the kind of a is coerced, and P might be dependent on the existential type variable a. @@ -1927,7 +1922,7 @@ -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- -data LiftingContext = LC TCvSubst LiftCoEnv +data LiftingContext = LC Subst LiftCoEnv -- in optCoercion, we need to lift when optimizing InstCo. -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. @@ -1968,14 +1963,14 @@ | otherwise = ty_co_subst lc r ty emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv +emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) (mkVarEnv pairs) -mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext :: Subst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv -- | Extend a lifting context with a new mapping. @@ -1996,7 +1991,7 @@ -> Coercion -- ^ to this coercion -> LiftingContext extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co -- | Extend a lifting context with existential-variable bindings. -- See Note [extendLiftingContextEx] @@ -2012,7 +2007,7 @@ -- works with existentially bound variables, which are considered to have -- nominal roles. | isTyVar v - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) (extendVarEnv env v $ mkGReflRightCo Nominal ty @@ -2030,7 +2025,7 @@ kco = mkTyConAppCo Nominal (equalityTyCon r) [ mkKindCo lift_s1, mkKindCo lift_s2 , lift_s1 , lift_s2 ] - lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) (extendVarEnv env v (mkProofIrrelCo Nominal kco co $ (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) @@ -2041,7 +2036,7 @@ -- | Erase the environments in a lifting context zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv +zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool @@ -2066,14 +2061,14 @@ = go role ty where go :: Role -> Type -> Coercion - go r ty | Just ty' <- coreView ty - = go r ty' - go Phantom ty = lift_phantom ty - go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ - liftCoSubstTyVar lc r tv - go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) - go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2) + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys) + go r (FunTy af w t1 t2) = mkFunCo1 r af (go Nominal w) (go r t1) (go r t2) go r t@(ForAllTy (Bndr v _) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v body_co = ty_co_subst lc' r ty in @@ -2192,14 +2187,14 @@ -> (LiftingContext, TyVar, r) liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isTyVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( LC (subst `extendSubstInScope` new_var) new_cenv , new_var, stuff ) where old_kind = tyVarKind old_var stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta -- :: new_var ~ new_var |> eta @@ -2212,14 +2207,14 @@ -> (LiftingContext, CoVar, r) liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isCoVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( LC (subst `extendSubstInScope` new_var) new_cenv , new_var, stuff ) where old_kind = coVarKind old_var stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) @@ -2231,8 +2226,8 @@ role = coVarRole old_var eta' = downgradeRole role Nominal eta - eta1 = mkNthCo role 2 eta' - eta2 = mkNthCo role 3 eta' + eta1 = mkSelCo (SelTyCon 2 role) eta' + eta2 = mkSelCo (SelTyCon 3 role) eta' co1 = mkCoVarCo new_var co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 @@ -2259,27 +2254,32 @@ swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv swapLiftCoEnv = mapVarEnv mkSymCo -lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft :: LiftingContext -> Subst lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env -lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight :: LiftingContext -> Subst lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst liftEnvSubstLeft = liftEnvSubst pFst -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst liftEnvSubstRight = liftEnvSubst pSnd -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst where pairs = nonDetUFMToList lc_env -- It's OK to use nonDetUFMToList here because we -- immediately forget the ordering by creating -- a VarEnv (tpairs, cpairs) = partitionWith ty_or_co pairs + -- Make sure the in-scope set is wide enough to cover the range of the + -- substitution (#22235). + in_scope = mkInScopeSet $ + tyCoVarsOfTypes (map snd tpairs) `unionVarSet` + tyCoVarsOfCos (map snd cpairs) tenv = mkVarEnv_Directly tpairs cenv = mkVarEnv_Directly cpairs @@ -2293,12 +2293,12 @@ equality_ty = selector (coercionKind co) -- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst +lcSubst :: LiftingContext -> Subst +lcSubst (LC subst _) = subst -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst +lcInScopeSet (LC subst _) = getSubstInScope subst {- %************************************************************************ @@ -2319,7 +2319,8 @@ seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k `seq` seqCo co -seqCo (FunCo r w co1 co2) = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 +seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq` + seqCo w `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv) = cv `seq` () seqCo (HoleCo h) = coHoleCoVar h `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos @@ -2327,7 +2328,7 @@ = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (NthCo r n co) = r `seq` n `seq` seqCo co +seqCo (SelCo n co) = n `seq` seqCo co seqCo (LRCo lr co) = lr `seq` seqCo co seqCo (InstCo co arg) = seqCo co `seq` seqCo arg seqCo (KindCo co) = seqCo co @@ -2378,25 +2379,27 @@ coercionLKind co = go co where - go (Refl ty) = ty - go (GRefl _ ty _) = ty - go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) - go (AppCo co1 co2) = mkAppTy (go co1) (go co2) - go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) - go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) - go (CoVarCo cv) = coVarLType cv - go (HoleCo h) = coVarLType (coHoleCoVar h) - go (UnivCo _ _ ty1 _) = ty1 - go (SymCo co) = coercionRKind co - go (TransCo co1 _) = go co1 - go (LRCo lr co) = pickLR lr (splitAppTy (go co)) - go (InstCo aco arg) = go_app aco [go arg] - go (KindCo co) = typeKind (go co) - go (SubCo co) = go co - go (NthCo _ d co) = go_nth d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos + go (Refl ty) = ty + go (GRefl _ ty _) = ty + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) + go (FunCo { fco_afl = af, fco_mult = mult, fco_arg = arg, fco_res = res}) + {- See Note [FunCo] -} = FunTy { ft_af = af, ft_mult = go mult + , ft_arg = go arg, ft_res = go res } + go (CoVarCo cv) = coVarLType cv + go (HoleCo h) = coVarLType (coHoleCoVar h) + go (UnivCo _ _ ty1 _) = ty1 + go (SymCo co) = coercionRKind co + go (TransCo co1 _) = go co1 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (SelCo d co) = getNthFromType d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos go_ax_inst ax ind tys | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs @@ -2416,49 +2419,55 @@ 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) -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = go_forall empty_subst co where - empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) go_ax_inst ax ind tys | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs @@ -2484,19 +2493,20 @@ where k2 = coercionRKind k_co tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendTCvInScope subst tv1 + subst' | isGReflCo k_co = extendSubstInScope subst tv1 -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ TyVarTy tv2 `mkCastTy` mkSymCo k_co go_forall subst (ForAllCo cv1 k_co 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 @@ -2509,8 +2519,8 @@ cv2 = setVarType cv1 (substTy subst k2) n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendTCvInScope subst cv1 - | otherwise = extendCvSubst (extendTCvInScope subst cv2) + subst' | isReflCo k_co = extendSubstInScope subst cv1 + | otherwise = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst go_forall subst other_co @@ -2543,14 +2553,16 @@ go (TyConAppCo r _ _) = r go (AppCo co1 _) = go co1 go (ForAllCo _ _ co) = go co - go (FunCo r _ _ _) = r + go (FunCo { fco_role = r }) = r go (CoVarCo cv) = coVarRole cv go (HoleCo h) = coVarRole (coHoleCoVar h) go (AxiomInstCo ax _ _) = coAxiomRole ax go (UnivCo _ r _ _) = r go (SymCo co) = go co go (TransCo co1 _co2) = go co1 - go (NthCo r _d _co) = r + go (SelCo SelForAll _co) = Nominal + go (SelCo (SelTyCon _ r) _co) = r + go (SelCo (SelFun fs) co) = funRole (coercionRole co) fs go (LRCo {}) = Nominal go (InstCo co _) = go co go (KindCo {}) = Nominal @@ -2585,11 +2597,6 @@ in TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] -mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type -mkHeteroCoercionType Nominal = mkHeteroPrimEqPred -mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred -mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" - -- | Creates a primitive type equality predicate. -- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type @@ -2649,20 +2656,21 @@ ; _ -> False }) $ mkNomReflCo ty1 - go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 }) - = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2) + go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + = assert (af1 == af2) $ + mkFunCo1 Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2) go (TyConApp tc1 args1) (TyConApp tc2 args2) = assert (tc1 == tc2) $ mkTyConAppCo Nominal tc1 (zipWith go args1 args2) go (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) @@ -2690,10 +2698,10 @@ 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 = mkEmptyTCvSubst $ mkInScopeSet $ + subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` mkCoVarCo cv1 `mkTransCo` diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -17,14 +17,16 @@ mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion mkTransCo :: Coercion -> Coercion -> Coercion -mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} @@ -35,6 +36,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic (Role(..)) + import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) @@ -508,14 +511,6 @@ Roles are defined here to avoid circular dependencies. -} - --- See Note [Roles] in GHC.Core.Coercion --- defined here to avoid cyclic dependency with GHC.Core.Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -15,6 +15,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Coercion import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) import GHC.Core.TyCon @@ -23,6 +24,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env +import GHC.Types.Unique.Set import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth ) @@ -32,7 +34,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Monad ( zipWithM ) @@ -43,6 +44,13 @@ %* * %************************************************************************ +This module does coercion optimisation. See the paper + + Evidence normalization in Systtem FV (RTA'13) + https://simon.peytonjones.org/evidence-normalization/ + +The paper is also in the GHC repo, in docs/opt-coercion. + Note [Optimising coercion optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Looking up a coercion's role or kind is linear in the size of the @@ -119,14 +127,25 @@ { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } -optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo +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 +-} -optCoercion' :: TCvSubst -> Coercion -> NormalCo + | otherwise + = substCo env co + + +optCoercion' :: Subst -> Coercion -> NormalCo optCoercion' env co | debugIsOn = let out_co = opt_co1 lc False co @@ -136,19 +155,23 @@ assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 && substTyUnchecked env in_ty2 `eqType` out_ty2 && in_role == out_role) - ( text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env)) - out_co + (hang (text "optCoercion changed types!") + 2 (vcat [ text "in_co:" <+> ppr co + , text "in_ty1:" <+> ppr in_ty1 + , text "in_ty2:" <+> ppr in_ty2 + , text "out_co:" <+> ppr out_co + , text "out_ty1:" <+> ppr out_ty1 + , text "out_ty2:" <+> ppr out_ty2 + , text "in_role:" <+> ppr in_role + , text "out_role:" <+> ppr out_role + , vcat $ map ppr_one $ nonDetEltsUniqSet $ coVarsOfCo co + , text "subst:" <+> ppr env ])) + out_co | otherwise = opt_co1 lc False co where lc = mkSubstLiftingContext env + ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) type NormalCo = Coercion @@ -191,9 +214,12 @@ -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo - +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag + -> Role -> Coercion -> NormalCo +-- Precondition: In every call (opt_co4 lc sym rep role co) +-- we should have role = coercionRole co opt_co4_wrap = opt_co4 + {- opt_co4_wrap env sym rep r co = pprTrace "opt_co4_wrap {" @@ -201,12 +227,13 @@ , text "Rep:" <+> ppr rep , text "Role:" <+> ppr r , text "Co:" <+> ppr co ]) $ - assert (r == coercionRole co ) + assert (r == coercionRole co ) $ let result = opt_co4 env sym rep r co in pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ result -} + opt_co4 env _ rep r (Refl ty) = assertPpr (r == Nominal) (text "Expected role:" <+> ppr r $$ @@ -246,7 +273,7 @@ (True, Nominal) -> mkTyConAppCo Representational tc (zipWith3 (opt_co3 env sym) - (map Just (tyConRolesRepresentational tc)) + (map Just (tyConRoleListRepresentational tc)) (repeat Nominal) cos) (False, Nominal) -> @@ -255,7 +282,7 @@ -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRolesRepresentational tc) -- the current roles + (tyConRoleListRepresentational tc) -- the current roles cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) @@ -269,18 +296,20 @@ 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 (lcTCvSubst env) cv + | Just co <- lookupCoVar (lcSubst env) cv = opt_co4_wrap (zapLiftingContext env) sym rep r co | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] @@ -333,38 +362,29 @@ co2' = opt_co4_wrap env sym rep r co2 in_scope = lcInScopeSet env -opt_co4 env _sym rep r (NthCo _r n co) - | Just (ty, _) <- isReflCo_maybe co - , Just (_tc, args) <- assert (r == _r ) - splitTyConApp_maybe ty - = liftCoSubst (chooseRole rep r) env (args `getNth` n) - - | Just (ty, _) <- isReflCo_maybe co - , n == 0 - , Just (tv, _) <- splitForAllTyCoVar_maybe ty - -- works for both tyvar and covar - = liftCoSubst (chooseRole rep r) env (varType tv) +opt_co4 env _sym rep r (SelCo n co) + | Just (ty, _co_role) <- isReflCo_maybe co + = liftCoSubst (chooseRole rep r) env (getNthFromType n ty) + -- NB: it is /not/ true that r = _co_role + -- Rather, r = coercionRole (SelCo n co) -opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) +opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos)) = assert (r == r1 ) opt_co4_wrap env sym rep r (cos `getNth` n) -- see the definition of GHC.Builtin.Types.Prim.funTyCon -opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2)) - = assert (r == r1 ) - opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2) +opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2)) + = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2) -opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) +opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _)) -- works for both tyvar and covar - = assert (r == _r ) - assert (n == 0 ) - opt_co4_wrap env sym rep Nominal eta + = opt_co4_wrap env sym rep Nominal eta -opt_co4 env sym rep r (NthCo _r n co) - | Just nth_co <- case co' of - TyConAppCo _ _ cos -> Just (cos `getNth` n) - FunCo _ w co1 co2 -> Just (mkNthCoFunCo n w co1 co2) - ForAllCo _ eta _ -> Just eta +opt_co4 env sym rep r (SelCo n co) + | Just nth_co <- case (co', n) of + (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n) + (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2) + (ForAllCo _ eta _, SelForAll) -> Just eta _ -> Nothing = if rep && (r == Nominal) -- keep propagating the SubCo @@ -372,7 +392,7 @@ else nth_co | otherwise - = wrapRole rep r $ NthCo r n co' + = wrapRole rep r $ SelCo n co' where co' = opt_co1 env sym co @@ -455,8 +475,8 @@ -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) r2 = coVarRole cv kind_co' = downgradeRole r2 Nominal kind_co - n1 = mkNthCo r2 2 kind_co' - n2 = mkNthCo r2 3 kind_co' + n1 = mkSelCo (SelTyCon 2 r2) kind_co' + n2 = mkSelCo (SelTyCon 3 r2) kind_co' in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) @@ -547,7 +567,7 @@ , equalLength tys1 tys2 -- see Note [Differing kinds] -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps - = let roles = tyConRolesX role tc1 + = let roles = tyConRoleListX role tc1 arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos in @@ -577,9 +597,9 @@ eta = mkUnivCo prov' Nominal k1 k2 eta_d = downgradeRole r' Nominal eta -- eta gets opt'ed soon, but not yet. - n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + n_co = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` - (mkNthCo r' 3 eta_d) + (mkSelCo (SelTyCon 3 r') eta_d) ty2' = substTyWithCoVars [cv2] [n_co] ty2 (env', cv1', eta') = optForAllCoBndr env sym cv1 eta @@ -651,13 +671,12 @@ mkGReflRightCo r1 t1 (opt_trans is co1 co2) -- Push transitivity through matching destructors -opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) +opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) | d1 == d2 , coercionRole co1 == coercionRole co2 , co1 `compatible_co` co2 - = assert (r1 == r2) $ - fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo r1 d1 (opt_trans is co1 co2) + = fireTransRule "PushNth" in_co1 in_co2 $ + mkSelCo d1 (opt_trans is co1 co2) opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) | d1 == d2 @@ -694,10 +713,14 @@ fireTransRule "PushTyConApp" in_co1 in_co2 $ mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) -opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b) - = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case +opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) + in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) + = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case + assert (afr1 == afl2) $ fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2) + (opt_trans is co1a co2a) + (opt_trans is co1b co2b) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) -- Must call opt_trans_rule_app; see Note [EtaAppCo] @@ -772,8 +795,8 @@ is' = is `extendInScopeSet` cv1 role = coVarRole cv1 eta1' = downgradeRole role Nominal eta1 - n1 = mkNthCo role 2 eta1' - n2 = mkNthCo role 3 eta1' + n1 = mkSelCo (SelTyCon 2 role) eta1' + n2 = mkSelCo (SelTyCon 3 role) eta1' r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` n2]) r2 @@ -1134,9 +1157,9 @@ Here, - h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) - eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) - eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h1 = mkSelCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3) + eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4) h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -} etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) @@ -1148,7 +1171,7 @@ | Pair ty1 ty2 <- coercionKind co , Just (tv1, _) <- splitForAllTyVar_maybe ty1 , isForAllTy_ty ty2 - , let kind_co = mkNthCo Nominal 0 co + , let kind_co = mkSelCo SelForAll co = Just ( tv1, kind_co , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) @@ -1164,13 +1187,13 @@ | Pair ty1 ty2 <- coercionKind co , Just (cv1, _) <- splitForAllCoVar_maybe ty1 , isForAllTy_co ty2 - = let kind_co = mkNthCo Nominal 0 co + = let kind_co = mkSelCo SelForAll co r = coVarRole cv1 l_co = mkCoVarCo cv1 kind_co' = downgradeRole r Nominal kind_co - r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` - l_co `mkTransCo` - (mkNthCo r 3 kind_co') + r_co = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co') + `mkTransCo` l_co + `mkTransCo` mkSelCo (SelTyCon 3 r) kind_co' in Just ( cv1, kind_co , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) @@ -1197,17 +1220,19 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn --- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +-- into [ SelCo (SelTyCon 0) g :: s1~t1 +-- , ... +-- , SelCo (SelTyCon (n-1)) g :: sn~tn ] etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) = assert (tc == tc2) $ Just cos2 etaTyConAppCo_maybe tc co - | not (mustBeSaturated tc) + | not (tyConMustBeSaturated tc) , (Pair ty1 ty2, r) <- coercionKindRole co , Just (tc1, tys1) <- splitTyConApp_maybe ty1 , Just (tc2, tys2) <- splitTyConApp_maybe ty2 , tc1 == tc2 - , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , isInjectiveTyCon tc r -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep , let n = length tys1 , tys2 `lengthIs` n -- This can fail in an erroneous program -- E.g. T a ~# T a b diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -185,10 +185,14 @@ -- -- 7) The original result type conLikeFullSig :: ConLike - -> ([TyVar], [TyCoVar], [EqSpec] + -> ([TyVar], [TyCoVar] -- Why tyvars for universal but tycovars for existential? -- See Note [Existential coercion variables] in GHC.Core.DataCon - , ThetaType, ThetaType, [Scaled Type], Type) + , [EqSpec] + , ThetaType -- Provided theta + , ThetaType -- Required theta + , [Scaled Type] -- Arguments + , Type ) -- Result conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con -- Required theta is empty as normal data cons require no additional diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary module GHC.Core.DataCon ( -- * Main data types @@ -19,7 +20,6 @@ -- ** Equality specs EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, -- ** Field labels FieldLabel(..), FieldLabelString, @@ -36,11 +36,11 @@ dataConDisplayType, dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, dataConUserTyVars, dataConUserTyVarBinders, - dataConEqSpec, dataConTheta, + dataConTheta, dataConStupidTheta, dataConOtherTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, + dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs, dataConInstUnivs, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, dataConSrcBangs, @@ -55,9 +55,10 @@ -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, - isUnboxedSumDataCon, - isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch, - dataConUserTyVarsArePermuted, + isUnboxedSumDataCon, isCovertGadtDataCon, + isVanillaDataCon, isNewDataCon, isTypeDataCon, + classDataCon, dataConCannotMatch, + dataConUserTyVarsNeedWrapper, checkDataConTyVars, isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, @@ -67,12 +68,15 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic + import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type 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 @@ -86,12 +90,11 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Unit.Types -import GHC.Unit.Module.Name 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 @@ -105,9 +108,11 @@ import Data.Char import Data.List( find ) +import Language.Haskell.Syntax.Module.Name + {- -Note [Data constructor representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration data T = T !Int ![Int] @@ -208,7 +213,7 @@ * The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments - If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys * The 'NoDataConRep' case of DataConRep is important. Not only is it efficient, but it also ensures that the wrapper is replaced by the @@ -228,7 +233,7 @@ data T = MkT !(Int,Int) \$wMkT :: (Int,Int) -> T \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has + Notice that the worker has two fields where the wrapper has just one. That is, the worker has type MkT :: Int -> Int -> T @@ -250,6 +255,8 @@ * Type variables may be permuted; see MkId Note [Data con wrappers and GADT syntax] +* Datatype contexts require dropping some dictionary arguments. + See Note [Instantiating stupid theta]. Note [The stupid context] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -282,7 +289,7 @@ I say the context is "stupid" because the dictionaries passed are immediately discarded -- they do nothing and have no benefit. -(See Note [Instantiating stupid theta] in GHC.Tc.Gen.Head.) +(See Note [Instantiating stupid theta].) It's a flaw in the language. GHC has made some efforts to correct this flaw. In GHC, datatype contexts @@ -326,6 +333,30 @@ result, dcStupidTheta is always empty for data types defined using GADT syntax. +Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a data type with a "stupid theta" (see +Note [The stupid context]): + + data Ord a => T a = MkT (Maybe a) + +We want to generate an Ord constraint for every use of MkT; but +we also want to allow visible type application, such as + + MkT @Int + +To achieve this, the wrapper for a data (or newtype) constructor +with a datatype context contains a lambda which drops the dictionary +argments corresponding to the datatype context: + + /\a \(_d:Ord a). MkT @a + +Notice that the wrapper discards the dictionary argument d. +We don't need it; it was only there to generate a Wanted constraint. +(That is why it is stupid.) + +This all happens in GHC.Types.Id.Make.mkDataConRep. + ************************************************************************ * * \subsection{Data constructors} @@ -391,7 +422,7 @@ -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) - -- Universally-quantified type vars [a,b,c] + -- dcUnivTyVars: Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon -- INVARIANT: result type of data con worker is exactly (T a b c) -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with @@ -400,16 +431,17 @@ -- 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 + -- So dcUserTyVarBinders is a subset of (dcUnivTyVars ++ dcExTyCoVars) -- See Note [DataCon user type variable binders] dcUserTyVarBinders :: [InvisTVBinder], @@ -522,7 +554,7 @@ * Each argument flag is Inferred or Specified. None are Required. (A DataCon is a term-level function; see - Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.) + Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep.) Why do we need the TyVarBinders, rather than just the TyVars? So that we can construct the right type for the DataCon with its foralls @@ -534,44 +566,59 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~ -A `DataCon`'s source arity and core representation arity may differ: -`dcSourceArity` does not take constraints into account, but `dcRepArity` does. - -The additional arguments taken into account by `dcRepArity` include quantified -dictionaries and coercion arguments, lifted and unlifted (despite the unlifted -coercion arguments having a zero-width runtime representation). -For example: +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: MkT :: Ord a => a -> T a dcSourceArity = 1 dcRepArity = 2 - MkU :: (b ~ '[]) => U b - dcSourceArity = 0 - dcRepArity = 1 - - 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 @@ -614,36 +661,119 @@ performs a stable topological sort on the type variables in the user-written type signature, which would place `b` before `a`. -But as noted above, enacting this behavior is not entirely trivial, as System -FC demands the variables go in universal-then-existential order under the hood. -Our solution is thus to equip DataCon with two different sets of type -variables: +--- Reason (R2): GADT constructors quantify over different variables --- -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential - type/coercion variables, respectively. Their order is irrelevant for the - purposes of TypeApplications, and as a consequence, they do not come equipped - with visibilities (that is, they are TyVars/TyCoVars instead of - TyCoVarBinders). +GADT constructors may quantify over different variables than the worker +would. Consider + data T a b where + MkT :: forall c d. c -> T [c] d -* dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. Their order *does* matter - for TypeApplications, so they are full TyVarBinders, complete with - visibilities. +The dcUserTyVarBinders must be [c, d] -- that's what the user quantified over. +But c is actually existential, as it is not equal to either of the two +universal variables. -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders -consists precisely of: +Here is what we'll get: + dcUserTyVarBinders = [c, d] + dcUnivTyVars = [a, d] + dcExTyCoVars = [c] + +Note that dcUnivTyVars contains `a` from the type header (the `data T a b`) +and `d` from the signature for MkT. This is done because d is used in place +of b in the result of MkT, and so we use the name d for the universal, as that +might improve error messages. On the other hand, we need to use a fresh name +for the first universal (recalling that the result of a worker must be the +type constructor applied to a sequence of plain variables), so we use `a`, from +the header. This choice of universals is made in GHC.Tc.TyCl.mkGADTVars. + +Because c is not a universal, it is an existential. Here, we see that (even +ignoring order) dcUserTyVarBinders is not dcUnivTyVars ⋃ dcExTyCoVars, because +the latter has `a` while the former does not. To understand this better, let's +look at this type for the "true underlying" worker data con: + + MkT :: forall a d. forall c. (a ~# [c]) => c -> T a d + +We see here that the `a` universal is connected with the `c` existential via +an equality constraint. It will always be the case (see the code in mkGADTVars) +that the universals not mentioned in dcUserTyVarBinders will be used in a +GADT equality -- that is, used on the left-hand side of an element of dcEqSpec: + + dcEqSpec = [a ~# [c]] + +Putting this all together, all variables used on the left-hand side of an +equation in the dcEqSpec will be in dcUnivTyVars but *not* in +dcUserTyVarBinders. + +--- Reason (R3): Kind equalities may have been solved --- + +Consider now this case: + + type family F a where + F Type = False + F _ = True + type T :: forall k. (F k ~ True) => k -> k -> Type + data T a b where + MkT :: T Maybe List + +The constraint F k ~ True tells us that T does not want to be indexed by, say, +Int. Now let's consider the Core types involved: + + axiom for F: axF[0] :: F Type ~ False + axF[1] :: forall a. F a ~ True (a must be apart from Type) + tycon: T :: forall k. (F k ~ True) -> k -> k -> Type + wrapper: MkT :: T @(Type -> Type) @(Eq# (axF[1] (Type -> Type)) Maybe List + worker: MkT :: forall k (c :: F k ~ True) (a :: k) (b :: k). + (k ~# (Type -> Type), a ~# Maybe, b ~# List) => + T @k @c a b + +The key observation here is that the worker quantifies over c, while the wrapper +does not. The worker *must* quantify over c, because c is a universal variable, +and the result of the worker must be the type constructor applied to a sequence +of plain type variables. But the wrapper certainly does not need to quantify over +any evidence that F (Type -> Type) ~ True, as no variables are needed there. + +(Aside: the c here is a regular type variable, *not* a coercion variable. This +is because F k ~ True is a *lifted* equality, not the unlifted ~#. This is why +we see Eq# in the type of the wrapper: Eq# boxes the unlifted ~# to become a +lifted ~. See also Note [The equality types story] in GHC.Builtin.Types.Prim about +Eq# and Note [Constraints in kinds] in GHC.Core.TyCo.Rep about having this constraint +in the first place.) + +In this case, we'll have these fields of the DataCon: + + dcUserTyVarBinders = [] -- the wrapper quantifies over nothing + dcUnivTyVars = [k, c, a, b] + dcExTyCoVars = [] -- no existentials here, but a different constructor might have + dcEqSpec = [k ~# (Type -> Type), a ~# Maybe, b ~# List] + +Note that c is in the dcUserTyVars, but mentioned neither in the dcUserTyVarBinders nor +in the dcEqSpec. We thus have Reason (R3): a variable might be missing from the +dcUserTyVarBinders if its type's kind is Constraint. + +(At one point, we thought that the dcEqSpec would have to be non-empty. But that +wouldn't account for silly cases like type T :: (True ~ True) => Type.) + +--- End of Reasons --- + +INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders +consists of: + * The set of tyvars in dcUnivTyVars whose type variables do not appear in dcEqSpec, unioned with: + * The set of tyvars (*not* covars) in dcExTyCoVars No covars here because because they're not user-written +When comparing for equality, we ignore differences concerning type variables +whose kinds have kind Constraint. + The word "set" is used above because the order in which the tyvars appear in dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of (tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the ordering, they in fact share the same type variables (with the same Uniques). We -sometimes refer to this as "the dcUserTyVarBinders invariant". +sometimes refer to this as "the dcUserTyVarBinders invariant". It is checked +in checkDataConTyVars. dcUserTyVarBinders, as the name suggests, is the one that users will see most of the time. It's used when computing the type signature of a @@ -730,30 +860,17 @@ -- after consulting HsSrcBang, flags, etc. data HsImplBang = HsLazy -- ^ Lazy field, or one with an unlifted type - | HsStrict -- ^ Strict but not unpacked field + | HsStrict Bool -- ^ Strict but not unpacked field + -- True <=> we could have unpacked, but opted not to + -- because of -O0. + -- See Note [Detecting useless UNPACK pragmas] | HsUnpack (Maybe Coercion) -- ^ Strict and unpacked field -- co :: arg-ty ~ product-ty HsBang deriving Data.Data --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - - ------------------------- -- StrictnessMark is used to indicate strictness -- of the DataCon *worker* fields @@ -762,8 +879,7 @@ -- | An 'EqSpec' is a tyvar/type pair representing an equality made in -- rejigging a GADT constructor -data EqSpec = EqSpec TyVar - Type +data EqSpec = EqSpec TyVar Type -- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec @@ -782,22 +898,6 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty | EqSpec tv ty <- spec ] --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec --- is mapped in the substitution, it is mapped to a type variable, not --- a full type. -substEqSpec :: TCvSubst -> 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) @@ -865,14 +965,49 @@ * The dcr_bangs field of the dcRep field records the [HsImplBang] If T was defined in this module, Without -O the dcr_bangs might be - [HsStrict, HsStrict, HsLazy] + [HsStrict _, HsStrict _, HsLazy] With -O it might be - [HsStrict, HsUnpack _, HsLazy] + [HsStrict _, HsUnpack _, HsLazy] With -funbox-small-strict-fields it might be [HsUnpack, HsUnpack _, HsLazy] With -XStrictData it might be - [HsStrict, HsUnpack _, HsStrict] + [HsStrict _, HsUnpack _, HsStrict _] +Note [Detecting useless UNPACK pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to issue a warning when there's an UNPACK pragma in the source code, +but we decided not to unpack. +However, when compiling with -O0, we never unpack, and that'd generate +spurious warnings. +Therefore, we remember in HsStrict a boolean flag, whether we _could_ +have unpacked. This flag is set in GHC.Types.Id.Make.dataConSrcToImplBang. +Then, in GHC.Tc.TyCl.checkValidDataCon (sub-function check_bang), +if the user wrote an `{-# UNPACK #-}` pragma (i.e. HsSrcBang contains SrcUnpack) +we consult HsImplBang: + + HsUnpack _ => field unpacked, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O] + HsStrict True => field not unpacked because -O0, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O0] + HsStrict False => field not unpacked, warning + Example: data T = MkT {-# UNPACK #-} !(Int -> Int) + HsLazy => field not unpacked, warning + This can happen in two scenarios: + + 1) UNPACK without a bang + Example: data T = MkT {-# UNPACK #-} Int + This will produce a warning about missing ! before UNPACK. + + 2) UNPACK of an unlifted datatype + Because of bug #20204, we currently do not unpack type T, + and therefore issue a warning: + type IntU :: UnliftedType + data IntU = IntU Int# + data T = Test {-# UNPACK #-} IntU + +The boolean flag is used only for this warning. +See #11270 for motivation. + Note [Data con representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The dcRepType field contains the type of the representation of a constructor @@ -895,7 +1030,7 @@ Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Note that this representation is still *different* from runtime +Not that this representation is still *different* from runtime representation. (Which is what STG uses after unarise). This is how T would end up being used in STG post-unarise: @@ -956,7 +1091,7 @@ ppr HsLazy = text "Lazy" ppr (HsUnpack Nothing) = text "Unpacked" ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) - ppr HsStrict = text "StrictNotUnpacked" + ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b) instance Outputable SrcStrictness where ppr SrcLazy = char '~' @@ -1009,7 +1144,7 @@ -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True -eqHsBang HsStrict HsStrict = True +eqHsBang (HsStrict _) (HsStrict _) = True eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) @@ -1059,7 +1194,7 @@ -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied (Scaled Type)] -- ^ Original argument types -> KnotTied Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo' + -> PromDataConInfo -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo' -> KnotTied TyCon -- ^ Representation type constructor -> ConTag -- ^ Constructor tag -> ThetaType -- ^ The "stupid theta", context of the data @@ -1120,8 +1255,11 @@ -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ - mkVisFunTys rep_arg_tys $ + mkScaledFunctionTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + -- res_arg_tys is a mixture of TypeLike and ConstraintLike, + -- so we don't know which FunTyFlag to use + -- Hence using mkScaledFunctionTys. -- See Note [Promoted data constructors] in GHC.Core.TyCon prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv @@ -1131,9 +1269,9 @@ -- fresh_names: make sure that the "anonymous" tyvars don't -- clash in name or unique with the universal/existential ones. -- Tiresome! And unnecessary because these tyvars are never looked at - prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + prom_theta_bndrs = [ mkInvisAnonTyConBinder (mkTyVar n t) {- Invisible -} | (n,t) <- fresh_names `zip` theta ] - prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + prom_arg_bndrs = [ mkAnonTyConBinder (mkTyVar n t) {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ] prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs prom_res_kind = orig_res_ty @@ -1220,30 +1358,6 @@ dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConUserTyVarBinders = dcUserTyVarBinders --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration. This includes *all* GADT-like --- equalities, including those written in by hand by the programmer. -dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = dataConKindEqSpec con - ++ eq_spec ++ - [ spec -- heterogeneous equality - | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` heqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] ++ - [ spec -- homogeneous equality - | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` eqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] - -- | Dependent (kind-level) equalities in a constructor. -- There are extracted from the existential variables. -- See Note [Existential coercion variables] @@ -1259,7 +1373,7 @@ | cv <- ex_tcvs , isCoVar cv , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv - tv = getTyVar "dataConKindEqSpec" ty1 + tv = getTyVar ty1 ] -- | The *full* constraints on the constructor type, including dependent GADT @@ -1332,10 +1446,9 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | Gives the number of value arguments (including zero-width coercions) --- stored by the given `DataCon`'s worker in its Core representation. This may --- differ from the number of arguments that appear in the source code; see also --- Note [DataCon arities] +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1344,14 +1457,8 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether this `DataCon`'s worker, in its Core representation, takes --- any value arguments. --- --- In particular, remember that we include coercion arguments in the arity of --- the Core representation of the `DataCon` -- both lifted and unlifted --- coercions, despite the latter having zero-width runtime representation. --- --- See also Note [DataCon arities]. +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 @@ -1483,10 +1590,11 @@ -- mentions the family tycon, not the internal one. dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) + dcOrigResTy = res_ty, + dcStupidTheta = stupid_theta }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany theta $ - mkVisFunTys arg_tys $ + mkInvisFunTys (stupid_theta ++ theta) $ + mkScaledFunTys arg_tys $ res_ty dataConNonlinearType :: DataCon -> Type @@ -1497,11 +1605,11 @@ 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 where - arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys + arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys dataConDisplayType :: Bool -> DataCon -> Type dataConDisplayType show_linear_types dc @@ -1593,7 +1701,7 @@ (text "dataConInstUnivs" <+> ppr dc_args <+> ppr (dataConUnivTyVars dc)) $ - splitAt (length dc_args) $ dataConUnivTyVars dc + splitAtList dc_args $ dataConUnivTyVars dc (_, dc_args_suffix) = substTyVarBndrs prefix_subst dc_univs_suffix prefix_subst = mkTvSubst prefix_in_scope prefix_env prefix_in_scope = mkInScopeSet $ tyCoVarsOfTypes dc_args @@ -1617,7 +1725,7 @@ , dcOtherTheta = theta , dcOrigArgTys = orig_arg_tys }) = case rep of - NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys + NoDataConRep -> assert (null eq_spec) $ map unrestricted theta ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached @@ -1657,6 +1765,66 @@ isNewDataCon :: DataCon -> Bool isNewDataCon dc = isNewTyCon (dataConTyCon dc) +-- | Is this data constructor in a "type data" declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +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 @@ -1697,17 +1865,71 @@ -- -- This is not a cheap test, so we minimize its use in GHC as much as possible. -- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in --- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- "MkId", and so 'dataConUserTyVarsNeedWrapper' is only called at most once -- during a data constructor's lifetime. +dataConResRepTyArgs :: DataCon -> [Type] +-- Returns the arguments of a GADT version of the /representation/ TyCon +-- Thus data instance T [(x,y)] z where +-- MkT :: forall p q. Int -> T [(Int,p)] (Maybe q) +-- The "GADT version of the representation type" is +-- data R:T x y z where +-- MkT :: forall p q. Int -> R:T Int p (Maybe q) +-- so dataConResRepTyArgs for MkT returns [Int, p, Maybe q] +-- This is almost the same as (subst eq_spec univ_tvs); but not quite, +-- because eq_spec omits constraint-kinded equalities +dataConResRepTyArgs dc@(MkData { dcRepTyCon = rep_tc, dcOrigResTy = orig_res_ty }) + | Just (fam_tc, fam_args) <- tyConFamInst_maybe rep_tc + = -- fvs(fam_args) = tyConTyVars rep_tc + -- These tyvars are the domain of subst + -- Fvs(range(subst)) = tvars of the datacon + case tcMatchTy (mkTyConApp fam_tc fam_args) orig_res_ty of + Just subst -> map (substTyVar subst) (tyConTyVars rep_tc) + Nothing -> pprPanic "datacOnResRepTyArgs" $ + vcat [ ppr dc, ppr fam_tc <+> ppr fam_args + , ppr orig_res_ty ] + | otherwise + = tyConAppArgs orig_res_ty + +checkDataConTyVars :: DataCon -> Bool +-- Check that the worker and wrapper have the same set of type variables +-- See Note [DataCon user type variable binders] +-- Also ensures that no user tyvar is in the eq_spec (the eq_spec should +-- only relate fresh universals from (R2) of the note) +checkDataConTyVars dc@(MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcEqSpec = eq_spec }) + -- use of sets here: (R1) from the Note + = mkUnVarSet depleted_worker_vars == mkUnVarSet depleted_wrapper_vars && + all (not . is_eq_spec_var) wrapper_vars + where + is_constraint_var v = typeTypeOrConstraint (tyVarKind v) == ConstraintLike + -- implements (R3) from the Note + + worker_vars = univ_tvs ++ ex_tvs + eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec) + is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs) -- (R2) from the Note + depleted_worker_vars = filterOut (is_eq_spec_var <||> is_constraint_var) + worker_vars + + wrapper_vars = dataConUserTyVars dc + depleted_wrapper_vars = filterOut is_constraint_var wrapper_vars + +dataConUserTyVarsNeedWrapper :: DataCon -> Bool +-- Check whether the worker and wapper have the same type variables +-- in the same order. If not, we need a wrapper to swizzle them. -- See Note [DataCon user type variable binders], as well as -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function. -dataConUserTyVarsArePermuted :: DataCon -> Bool -dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs - , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec - , dcUserTyVarBinders = user_tvbs }) = - (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs +dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcEqSpec = eq_spec }) + = assert (null eq_spec || answer) -- all GADTs should say "yes" here + answer + where + answer = (univ_tvs ++ ex_tvs) /= dataConUserTyVars dc + -- Worker tyvars Wrapper tyvars + {- %************************************************************************ diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -27,6 +27,7 @@ dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) isUnboxedSumDataCon :: DataCon -> Bool +isTypeDataCon :: DataCon -> Bool instance Eq DataCon instance Uniquable DataCon diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -36,12 +36,12 @@ ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, - expr_fvs, + exprFVs, -- * Orphan names - orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, - orphNamesOfTypes, orphNamesOfCoCon, - exprsOrphNames, orphNamesOfFamInst, + orphNamesOfType, orphNamesOfTypes, + orphNamesOfCo, orphNamesOfCoCon, orphNamesOfAxiomLHS, + exprsOrphNames, -- * Core syntax tree annotation with free variables FVAnn, -- annotation, abstract @@ -70,9 +70,8 @@ import GHC.Core.TyCo.FVs 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 +348,25 @@ -- Look through type synonyms (#4912) orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res orphNamesOfType (TyConApp tycon tys) = func `unionNameSet` orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys where func = case tys of - arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg + arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg _ -> emptyNameSet -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) - `unionNameSet` orphNamesOfType res -orphNamesOfType (FunTy _ w arg res) = orph_names_of_fun_ty_con w - `unionNameSet` unitNameSet funTyConName + +orphNamesOfType (FunTy af w arg res) = func + `unionNameSet` unitNameSet fun_tc `unionNameSet` orphNamesOfType w `unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType res + where func | isVisibleFunArg af = orph_names_of_fun_ty_con w + | otherwise = emptyNameSet + + fun_tc = tyConName (funTyFlagTyCon af) + orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co orphNamesOfType (CoercionTy co) = orphNamesOfCo co @@ -381,15 +386,19 @@ orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (ForAllCo _ kind_co co) - = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co -orphNamesOfCo (FunCo _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ kind_co co) = orphNamesOfCo kind_co + `unionNameSet` orphNamesOfCo co +orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 }) + = orphNamesOfCo co_mult + `unionNameSet` orphNamesOfCo co1 + `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 + `unionNameSet` orphNamesOfType t2 orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co +orphNamesOfCo (SelCo _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg orphNamesOfCo (KindCo co) = orphNamesOfCo co @@ -410,11 +419,6 @@ orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches -orphNamesOfAxiom :: CoAxiom br -> NameSet -orphNamesOfAxiom axiom - = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) - `extendNameSet` getName (coAxiomTyCon axiom) - orphNamesOfCoAxBranches :: Branches br -> NameSet orphNamesOfCoAxBranches = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches @@ -423,22 +427,25 @@ orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs --- | orphNamesOfAxiom collects the names of the concrete types and +-- | `orphNamesOfAxiomLHS` collects the names of the concrete types and -- type constructors that make up the LHS of a type family instance, -- including the family name itself. -- -- For instance, given `type family Foo a b`: -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] -- --- Used in the implementation of ":info" in GHCi. -orphNamesOfFamInst :: FamInst -> NameSet -orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) +-- Used (via orphNamesOfFamInst) in the implementation of ":info" in GHCi. +-- and when determining orphan-hood for a FamInst or module +orphNamesOfAxiomLHS :: CoAxiom br -> NameSet +orphNamesOfAxiomLHS axiom + = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) -- 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 +798,4 @@ 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 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations @@ -11,7 +10,7 @@ module GHC.Core.FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, + pprFamInst, pprFamInsts, orphNamesOfFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, @@ -42,14 +41,17 @@ 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 import GHC.Core.Reduction import GHC.Core.RoughMap +import GHC.Core.FVs( orphNamesOfAxiomLHS ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name +import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc @@ -61,7 +63,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain + +import GHC.Types.Name.Set import GHC.Data.Bag +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf {- ************************************************************************ @@ -204,6 +210,10 @@ DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax + + {- ************************************************************************ * * @@ -366,7 +376,7 @@ data FamInstEnv = FamIE !Int -- The number of instances, used to choose the smaller environment - -- when checking type family consistnecy of home modules. + -- when checking type family consistency of home modules. !(RoughMap FamInst) -- See Note [FamInstEnv] -- See Note [FamInstEnv determinism] @@ -550,38 +560,42 @@ | InjectivityUnified CoAxBranch CoAxBranch -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for -- closed type families where equation after unification might be - -- overlpapped (in which case it is OK if they don't unify). Constructor + -- overlapped (in which case it is OK if they don't unify). Constructor -- stores axioms after unification. -- | Check whether two type family axioms don't violate injectivity annotation. injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch -> InjectivityCheckResult injectiveBranches injectivity - ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + ax1@(CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) -- See Note [Verifying injectivity annotation], case 1. = let getInjArgs = filterByList injectivity - in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + in_scope = mkInScopeSetList (tvs1 ++ tvs2) + in case tcUnifyTyWithTFs True in_scope rhs1 rhs2 of -- True = two-way pre-unification Nothing -> InjectivityAccepted -- RHS are different, so equations are injective. -- This is case 1A from Note [Verifying injectivity annotation] - Just subst -> -- RHS unify under a substitution - let lhs1Subst = Type.substTys subst (getInjArgs lhs1) - lhs2Subst = Type.substTys subst (getInjArgs lhs2) - -- If LHSs are equal under the substitution used for RHSs then this pair - -- of equations does not violate injectivity annotation. If LHSs are not - -- equal under that substitution then this pair of equations violates - -- injectivity annotation, but for closed type families it still might - -- be the case that one LHS after substitution is unreachable. - in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. - then InjectivityAccepted - else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 - , cab_rhs = Type.substTy subst rhs1 }) - ( ax2 { cab_lhs = Type.substTys subst lhs2 - , cab_rhs = Type.substTy subst rhs2 }) - -- payload of InjectivityUnified used only for check 1B2, only - -- for closed type families + Just subst -- RHS unify under a substitution + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + | eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + -> InjectivityAccepted + | otherwise + -> InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- Payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + where + lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- takes a CoAxiom with unknown branch incompatibilities and computes -- the compatibilities -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom @@ -683,7 +697,7 @@ -- See Note [Tidy axioms when we build them] -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom - init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")] init_tidy_env = mkEmptyTidyEnv init_occ_env -- See Note [Always number wildcard types in CoAxBranch] @@ -917,7 +931,7 @@ lookupFamInstEnvInjectivityConflicts :: [Bool] -- injectivity annotation for this type family instance -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far + -> FamInstEnvs -- all type instances seen so far -> FamInst -- new type instance that we're checking -> [CoAxBranch] -- conflicting instance declarations lookupFamInstEnvInjectivityConflicts injList fam_inst_envs @@ -1312,7 +1326,7 @@ unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) unwrapNewTypeStepper' rec_nts tc tys - = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys -- second coercion below is the kind coercion relating the original type's kind -- to the normalised type's kind @@ -1324,16 +1338,50 @@ _ -> NS_Done --------------- +-- | Try to simplify a type-family application, by *one* step +-- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co) +-- then co :: F tys ~R# rhs +-- res_co :: typeKind(F tys) ~ typeKind(rhs) +-- Type families and data families; always Representational role +topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] + -> Maybe HetReduction +topReduceTyFamApp_maybe envs fam_tc arg_tys + | isFamilyTyCon fam_tc -- type families and data families + , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys + = Just $ + mkHetReduction + (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) + res_co + | otherwise + = Nothing + where + role = Representational + ArgsReductions (Reductions args_cos ntys) res_co + = initNormM envs role (tyCoVarsOfTypes arg_tys) + $ normalise_tc_args fam_tc arg_tys + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> Reduction +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +--------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys = initNormM env role (tyCoVarsOfTypes tys) $ normalise_tc_app tc tys +------------------------------------------------------- +-- Functions that work in the NormM monad +------------------------------------------------------- + -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys , not (isFamFreeTyCon tc) -- Expand and try again = -- A synonym with type families in the RHS -- Expand and try again @@ -1372,41 +1420,11 @@ assemble_result r redn kind_co = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) ---------------- --- | Try to simplify a type-family application, by *one* step --- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co) --- then co :: F tys ~R# rhs --- res_co :: typeKind(F tys) ~ typeKind(rhs) --- Type families and data families; always Representational role -topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] - -> Maybe HetReduction -topReduceTyFamApp_maybe envs fam_tc arg_tys - | isFamilyTyCon fam_tc -- type families and data families - , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys - = Just $ - mkHetReduction - (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) - res_co - | otherwise - = Nothing - where - role = Representational - ArgsReductions (Reductions args_cos ntys) res_co - = initNormM envs role (tyCoVarsOfTypes arg_tys) - $ normalise_tc_args fam_tc arg_tys - normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys = do { role <- getRole ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys } ---------------- -normaliseType :: FamInstEnvs - -> Role -- desired role of coercion - -> Type -> Reduction -normaliseType env role ty - = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty - normalise_type :: Type -> NormM Reduction -- Normalise the input type, by eliminating *all* type-function redexes -- but *not* newtypes (which are visible to the programmer) @@ -1469,7 +1487,7 @@ Nothing -> do { ArgsReductions redns res_co <- normalise_args (typeKind nfun) - (repeat Nominal) + (Inf.repeat Nominal) arg_tys ; role <- getRole ; return $ @@ -1478,7 +1496,7 @@ (mkSymMCo res_co) } } normalise_args :: Kind -- of the function - -> [Role] -- roles at which to normalise args + -> Infinite Role -- roles at which to normalise args -> [Type] -- args -> NormM ArgsReductions -- returns ArgsReductions (Reductions cos xis) res_co, @@ -1488,7 +1506,7 @@ -- but the resulting application *will* be well-kinded -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args - = do { normed_args <- zipWithM normalise1 roles args + = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args } where (ki_binders, inner_ki) = splitPiTys fun_ki diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -32,24 +32,27 @@ isOverlappable, isOverlapping, isIncoherent ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) 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 ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE import Data.Maybe ( isJust ) import GHC.Utils.Outputable @@ -229,10 +232,8 @@ instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyvars from the ClsInst -instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) +instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys }) = (tvs, cls, tys) - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) -- | Collects the names of concrete types and type constructors that make -- up the head of a class instance. For instance, given `class Foo a b`: @@ -280,16 +281,18 @@ -- See Note [When exactly is an instance decl an orphan?] orph | is_local cls_name = NotOrphan (nameOccName cls_name) - | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns + | all notOrphan mb_ns = NE.head mb_ns | otherwise = IsOrphan notOrphan NotOrphan{} = True notOrphan _ = False - mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name - -- that is not in the "determined" arguments - mb_ns | null fds = [choose_one arg_names] - | otherwise = map do_one fds + mb_ns :: NonEmpty IsOrphan + -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns = case nonEmpty fds of + Nothing -> NE.singleton (choose_one arg_names) + Just fds -> fmap do_one fds do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names , not (tv `elem` rtvs)] @@ -319,7 +322,9 @@ {- Note [When exactly is an instance decl an orphan?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +(See GHC.Iface.Make.instanceToIfaceInst, which implements this.) +See Note [Orphans] in GHC.Core + Roughly speaking, an instance is an orphan if its head (after the =>) mentions nothing defined in this module. @@ -965,7 +970,7 @@ (m:_) | isIncoherent (fst m) -> NoUnifiers _ -> all_unifs - -- NOTE [Safe Haskell isSafeOverlap] + -- Note [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We restrict code compiled in 'Safe' mode from overriding code -- compiled in any other mode. The rationale is that code compiled @@ -1059,7 +1064,7 @@ A2. M is not overlapping, A3. G is overlapping. - This means that we eliminate G from the set of matches (it is overriden by M), + This means that we eliminate G from the set of matches (it is overridden by M), but we keep it around until we are done with instance resolution because it might still be useful to eliminate other matches. @@ -1067,7 +1072,7 @@ There are two situations in which guards can eliminate a match: - B1. We want to add a new instance, but it is overriden by a guard. + B1. We want to add a new instance, but it is overridden by a guard. We can immediately discard the instance. Example for B1: @@ -1080,7 +1085,7 @@ Processing them in order: we add J1 as a match, then J2 as a guard. Now, when we come across J3, we can immediately discard it because - it is overriden by the guard J2. + it is overridden by the guard J2. B2. We have found a new guard. We must use it to discard matches we have already found. This is necessary because we must obtain @@ -1096,7 +1101,7 @@ We start by considering K1 and K2. Neither has any overlapping flag set, so we end up with two matches, {K1, K2}. - Next we look at K3: it is overriden by K1, but as K1 is not + Next we look at K3: it is overridden by K1, but as K1 is not overlapping this means K3 should function as a guard. We must then ensure we eliminate K2 from the list of matches, as K3 guards against it. diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1,3441 +1,3630 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -A ``lint'' pass to check for Core correctness. -See Note [Core Lint guarantee]. --} - -module GHC.Core.Lint ( - lintCoreBindings, lintUnfolding, - lintPassResult, lintInteractiveExpr, lintExpr, - lintAnnots, lintAxioms, - - interactiveInScope, - - -- ** Debug output - endPass, endPassIO, - displayLintResults, dumpPassResult - ) where - -import GHC.Prelude - -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Env -import GHC.Driver.Config.Diagnostic - -import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) -import GHC.Unit.Module.ModGuts -import GHC.Runtime.Context - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.Opt.Monad -import GHC.Core.DataCon -import GHC.Core.Ppr -import GHC.Core.Coercion -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.Subst -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) -import GHC.Core.TyCon as TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.FamInstEnv( compatibleBranches ) -import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) -import GHC.Core.Coercion.Opt ( checkAxInstCo ) -import GHC.Core.Opt.Arity ( typeArity ) - -import GHC.Types.Literal -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.SrcLoc -import GHC.Types.Tickish -import GHC.Types.RepType -import GHC.Types.Basic -import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) -import GHC.Types.TypeEnv - -import GHC.Builtin.Names -import GHC.Builtin.Types.Prim -import GHC.Builtin.Types ( multiplicityTy ) - -import GHC.Data.Bag -import GHC.Data.List.SetOps - -import GHC.Utils.Monad -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc -import GHC.Utils.Trace -import GHC.Utils.Error -import qualified GHC.Utils.Error as Err -import GHC.Utils.Logger - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( NonEmpty(..), groupWith ) -import Data.List ( partition ) -import Data.Maybe -import GHC.Data.Pair -import qualified GHC.LanguageExtensions as LangExt - -{- -Note [Core Lint guarantee] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Core Lint is the type-checker for Core. Using it, we get the following guarantee: - -If all of: -1. Core Lint passes, -2. there are no unsafe coercions (i.e. unsafeEqualityProof), -3. all plugin-supplied coercions (i.e. PluginProv) are valid, and -4. all case-matches are complete -then running the compiled program will not seg-fault, assuming no bugs downstream -(e.g. in the code generator). This guarantee is quite powerful, in that it allows us -to decouple the safety of the resulting program from the type inference algorithm. - -However, do note point (4) above. Core Lint does not check for incomplete case-matches; -see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, -an incomplete case-match might slip by Core Lint and cause trouble at runtime. - -Note [GHC Formalism] -~~~~~~~~~~~~~~~~~~~~ -This file implements the type-checking algorithm for System FC, the "official" -name of the Core language. Type safety of FC is heart of the claim that -executables produced by GHC do not have segmentation faults. Thus, it is -useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document core-spec.pdf built in docs/core-spec that -contains a formalism of the types and functions dealt with here. If you change -just about anything in this file or you change other types/functions throughout -the Core language (all signposted to this note), you should update that -formalism. See docs/core-spec/README for more info about how to do so. - -Note [check vs lint] -~~~~~~~~~~~~~~~~~~~~ -This file implements both a type checking algorithm and also general sanity -checking. For example, the "sanity checking" checks for TyConApp on the left -of an AppTy, which should never happen. These sanity checks don't really -affect any notion of type soundness. Yet, it is convenient to do the sanity -checks at the same time as the type checks. So, we use the following naming -convention: - -- Functions that begin with 'lint'... are involved in type checking. These - functions might also do some sanity checking. - -- Functions that begin with 'check'... are *not* involved in type checking. - They exist only for sanity checking. - -Issues surrounding variable naming, shadowing, and such are considered *not* -to be part of type checking, as the formalism omits these details. - -Summary of checks -~~~~~~~~~~~~~~~~~ -Checks that a set of core bindings is well-formed. The PprStyle and String -just control what we print in the event of an error. The Bool value -indicates whether we have done any specialisation yet (in which case we do -some extra checks). - -We check for - (a) type errors - (b) Out-of-scope type variables - (c) Out-of-scope local variables - (d) Ill-kinded types - (e) Incorrect unsafe coercions - -If we have done specialisation the we check that there are - (a) No top-level bindings of primitive (unboxed type) - -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. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Bool in - let x::a = True in -That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". -One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] -in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). - -* Hence when linting we need to remember that a=Int, else we - might reject a correct program. So we carry a type substitution (in - this example [a -> Bool]) and apply this substitution before - comparing types. In effect, in Lint, type equality is always - equality-modulo-le-subst. This is in the le_subst field of - LintEnv. But nota bene: - - (SI1) The le_subst substitution is applied to types and coercions only - - (SI2) The result of that substitution is used only to check for type - equality, to check well-typed-ness, /but is then discarded/. - The result of substittion does not outlive the CoreLint pass. - - (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. - -* The function - lintInTy :: Type -> LintM (Type, Kind) - returns a substituted type. - -* When we encounter a binder (like x::a) we must apply the substitution - to the type of the binding variable. lintBinders does this. - -* Clearly we need to clone tyvar binders as we go. - -* But take care (#17590)! We must also clone CoVar binders: - let a = TYPE (ty |> cv) - in \cv -> blah - blindly substituting for `a` might capture `cv`. - -* Alas, when cloning a coercion variable we might choose a unique - that happens to clash with an inner Id, thus - \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` because it's already in scope. Fine, - choose a new unique. Aha, X7 looks good. So we check the lambda - body with le_subst of [cv_66 :-> cv_X7] - - This is all fine, even though we use the same unique as wild_X7. - As (SI2) says, we do /not/ return a new lambda - (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst substitution in types/coercions only, when - checking for equality. - -* We still need to check that Id occurrences are bound by some - enclosing binding. We do /not/ use the InScopeSet for the le_subst - for this purpose -- it contains only TyCoVars. Instead we have a separate - le_ids for the in-scope Id binders. - -Sigh. We might want to explore getting rid of type-let! - -Note [Bad unsafe coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions -Linter introduces additional rules that checks improper coercion between -different types, called bad coercions. Following coercions are forbidden: - - (a) coercions between boxed and unboxed values; - (b) coercions between unlifted values of the different sizes, here - active size is checked, i.e. size of the actual value but not - the space allocated for value; - (c) coercions between floating and integral boxed values, this check - is not yet supported for unboxed tuples, as no semantics were - specified for that; - (d) coercions from / to vector type - (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be - coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules - (a-e) holds. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -We check the rules listed in Note [Invariants on join points] in GHC.Core. The -only one that causes any difficulty is the first: All occurrences must be tail -calls. To this end, along with the in-scope set, we remember in le_joins the -subset of in-scope Ids that are valid join ids. For example: - - join j x = ... in - case e of - A -> jump j y -- good - B -> case (jump j z) of -- BAD - C -> join h = jump j w in ... -- good - D -> let x = jump j v in ... -- BAD - -A join point remains valid in case branches, so when checking the A -branch, j is still valid. When we check the scrutinee of the inner -case, however, we set le_joins to empty, and catch the -error. Similarly, join points can occur free in RHSes of other join -points but not the RHSes of value bindings (thunks and functions). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ - -These functions are not CoreM monad stuff, but they probably ought to -be, and it makes a convenient place for them. They print out stuff -before and after core passes, and do Core Lint when necessary. --} - -endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () -endPass pass binds rules - = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified - ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } - -endPassIO :: HscEnv -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () --- Used by the IO-is CorePrep too -endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult logger dump_core_sizes print_unqual mb_flag - (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules - ; lintPassResult hsc_env pass binds } - where - dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) - logger = hsc_logger hsc_env - dflags = hsc_dflags hsc_env - mb_flag = case coreDumpFlag pass of - Just flag | logHasDumpFlag logger flag -> Just flag - | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag - _ -> Nothing - -dumpPassResult :: Logger - -> Bool -- dump core sizes? - -> PrintUnqualified - -> Maybe DumpFlag -- Just df => show details in a file whose - -- name is specified by df - -> String -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> do - logDumpFile logger (mkDumpStyle unqual) flag hdr FormatCore dump_doc - - -- Report result size - -- This has the side effect of forcing the intermediate to be evaluated - -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg logger 2 size_doc - } - - where - size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] - - dump_doc = vcat [ nest 2 extra_info - , size_doc - , blankLine - , if dump_core_sizes - then pprCoreBindingsWithSize binds - else pprCoreBindings binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -coreDumpFlag :: CoreToDo -> Maybe DumpFlag -coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal -coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal -coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper -coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec -coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep -coreDumpFlag CoreAddLateCcs = Just Opt_D_dump_late_cc - -coreDumpFlag CoreAddCallerCcs = Nothing -coreDumpFlag CoreOccurAnal = Nothing -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () -lintPassResult hsc_env pass binds - | not (gopt Opt_DoCoreLinting dflags) - = return () - | otherwise - = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds - ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults logger (showLintWarnings pass) (ppr pass) - (pprCoreBindings binds) warns_and_errs } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -displayLintResults :: Logger - -> Bool -- ^ If 'True', display linter warnings. - -- If 'False', ignore linter warnings. - -> SDoc -- ^ The source of the linted program - -> SDoc -- ^ The linted program, pretty-printed - -> WarnsAndErrs - -> IO () -displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) - | not (isEmptyBag errs) - = do { logMsg logger Err.MCDump noSrcSpan - $ withPprStyle defaultDumpStyle - (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs - , text "*** Offending Program ***" - , pp_pgm - , text "*** End of Offense ***" ]) - ; Err.ghcExit logger 1 } - - | not (isEmptyBag warns) - , log_enable_debug (logFlags logger) - , display_warnings - -- If the Core linter encounters an error, output to stderr instead of - -- stdout (#13342) - = logMsg logger Err.MCInfo noSrcSpan - $ withPprStyle defaultDumpStyle - (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) - - | otherwise = return () - -lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = text "*** Core Lint" <+> text string - <+> text ": in result of" <+> pass - <+> text "***" - -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False -showLintWarnings _ = True - -lintInteractiveExpr :: SDoc -- ^ The source of the linted expression - -> HscEnv -> CoreExpr -> IO () -lintInteractiveExpr what hsc_env expr - | not (gopt Opt_DoCoreLinting dflags) - = return () - | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr - = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err) - | otherwise - = return () - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -interactiveInScope :: InteractiveContext -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope ictxt - = tyvars ++ ids - where - -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings dflags pass local_in_scope binds - = initL dflags flags local_in_scope $ - addLoc TopLevelBindings $ - do { checkL (null dups) (dupVars dups) - ; checkL (null ext_dups) (dupExtVars ext_dups) - ; lintRecBindings TopLevel all_pairs $ \_ -> - return () } - where - all_pairs = flattenBinds binds - -- Put all the top-level binders in scope at the start - -- This is because rewrite rules can bring something - -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" - binders = map fst all_pairs - - flags = (defaultLintFlags dflags) - { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs - , lf_check_static_ptrs = check_static_ptrs - , lf_check_linearity = check_linearity - , lf_check_fixed_rep = check_fixed_rep } - - -- In the output of the desugarer, before optimisation, - -- we have eta-expanded data constructors with representation-polymorphic - -- bindings; so we switch off the representation-polymorphism checks. - -- The very simple optimiser will beta-reduce them away. - -- See Note [Checking for representation-polymorphic built-ins] - -- in GHC.HsToCore.Expr. - check_fixed_rep = case pass of - CoreDesugar -> False - _ -> True - - -- See Note [Checking for global Ids] - check_globals = case pass of - CoreTidy -> False - CorePrep -> False - _ -> True - - -- See Note [Checking for INLINE loop breakers] - check_lbs = case pass of - CoreDesugar -> False - CoreDesugarOpt -> False - _ -> True - - -- See Note [Checking StaticPtrs] - check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere - | otherwise = case pass of - CoreDoFloatOutwards _ -> AllowAtTopLevel - CoreTidy -> RejectEverywhere - CorePrep -> AllowAtTopLevel - _ -> AllowAnywhere - - -- See Note [Linting linearity] - check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( - case pass of - CoreDesugar -> True - _ -> False) - - (_, dups) = removeDups compare binders - - -- dups_ext checks for names with different uniques - -- but the same External name M.n. We don't - -- allow this at top level: - -- M.n{r3} = ... - -- M.n{r29} = ... - -- because they both get the same linker symbol - ext_dups = snd (removeDups ord_ext (map Var.varName binders)) - ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 - , Just m2 <- nameModule_maybe n2 - = compare (m1, nameOccName n1) (m2, nameOccName n2) - | otherwise = LT - -{- -************************************************************************ -* * -\subsection[lintUnfolding]{lintUnfolding} -* * -************************************************************************ - -Note [Linting Unfoldings from Interfaces] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use this to check all top-level unfoldings that come in from interfaces -(it is very painful to catch errors otherwise). - -We do not need to call lintUnfolding on unfoldings that are nested within -top-level unfoldings; they are linted when we lint the top-level unfolding; -hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. - --} - -lintUnfolding :: Bool -- ^ True <=> is a compulsory unfolding - -> DynFlags - -> SrcLoc - -> VarSet -- ^ Treat these as in scope - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintUnfolding is_compulsory dflags locn var_set expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - vars = nonDetEltsUniqSet var_set - (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ - if is_compulsory - -- See Note [Checking for representation polymorphism] - then noFixedRuntimeRepChecks linter - else linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: DynFlags - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintExpr dflags vars expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter - linter = addLoc TopLevelBindings $ - lintCoreExpr expr - -{- -************************************************************************ -* * -\subsection[lintCoreBinding]{lintCoreBinding} -* * -************************************************************************ - -Check a core binding, returning the list of variables bound. --} - --- Returns a UsageEnv because this function is called in lintCoreExpr for --- Let - -lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv]) -lintRecBindings top_lvl pairs thing_inside - = lintIdBndrs top_lvl bndrs $ \ bndrs' -> - do { ues <- zipWithM lint_pair bndrs' rhss - ; a <- thing_inside bndrs' - ; return (a, ues) } - where - (bndrs, rhss) = unzip pairs - lint_pair bndr' rhs - = addLoc (RhsOf bndr') $ - do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty - ; return ue } - -lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv) -lintLetBody bndrs body - = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) - ; mapM_ (lintJoinBndrType body_ty) bndrs - ; return (body_ty, body_ue) } - -lintLetBind :: TopLevelFlag -> RecFlag -> LintedId - -> CoreExpr -> LintedType -> LintM () --- Binder's type, and the RHS, have already been linted --- This function checks other invariants -lintLetBind top_lvl rec_flag binder rhs rhs_ty - = do { let binder_ty = idType binder - ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) - - -- If the binding is for a CoVar, the RHS should be (Coercion co) - -- See Note [Core type and coercion invariant] in GHC.Core - ; checkL (not (isCoVar binder) || isCoArg rhs) - (mkLetErr binder rhs) - - -- Check the let/app invariant - -- See Note [Core let/app invariant] in GHC.Core - ; checkL ( isJoinId binder - || mightBeLiftedType binder_ty - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal. - -- See Note [Core top-level string literals]. - ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) - - ; flags <- getLintFlags - - -- Check that a join-point binder has a valid type - -- NB: lintIdBinder has checked that it is not top-level bound - ; case isJoinId_maybe binder of - Nothing -> return () - Just arity -> checkL (isValidJoinPointType arity binder_ty) - (mkInvalidJoinPointMsg binder binder_ty) - - ; when (lf_check_inline_loop_breakers flags - && isStableUnfolding (realIdUnfolding binder) - && isStrongLoopBreaker (idOccInfo binder) - && isInlinePragma (idInlinePragma binder)) - (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- We used to check that the dmdTypeDepth of a demand signature never - -- exceeds idArity, but that is an unnecessary complication, see - -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal - - -- Check that the binder's arity is within the bounds imposed by - -- the type and the strictness signature. See Note [exprArity invariant] - -- and Note [Trimming arity] - ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> - ppr binder) - - ; case splitDmdSig (idDmdSig binder) of - (demands, result_info) | isDeadEndDiv result_info -> - checkL (demands `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds arity imposed by the strictness signature" <+> - ppr (idDmdSig binder) <> colon <+> - ppr binder) - _ -> return () - - ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) - - ; addLoc (UnfoldingOf binder) $ - lintIdUnfolding binder binder_ty (idUnfolding binder) - ; return () } - - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - --- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' --- in that it doesn't reject occurrences of the function 'makeStatic' when they --- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and --- for join points, it skips the outer lambdas that take arguments to the --- join point. --- --- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv) --- NB: the Id can be Linted or not -- it's only used for --- its OccInfo and join-pointer-hood -lintRhs bndr rhs - | Just arity <- isJoinId_maybe bndr - = lintJoinLams arity (Just bndr) rhs - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lintJoinLams arity Nothing rhs - --- Allow applications of the data constructor @StaticPtr@ at the top --- but produce errors otherwise. -lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go - where - -- Allow occurrences of 'makeStatic' at the top-level but produce errors - -- otherwise. - go :: StaticPtrCheck -> LintM (OutType, UsageEnv) - go AllowAtTopLevel - | (binders0, rhs') <- collectTyBinders rhs - , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' - = markAllJoinsBad $ - foldr - -- imitate @lintCoreExpr (Lam ...)@ - lintLambda - -- imitate @lintCoreExpr (App ...)@ - (do fun_ty_ue <- lintCoreExpr fun - lintCoreArgs fun_ty_ue [Type t, info, e] - ) - binders0 - go _ = markAllJoinsBad $ lintCoreExpr rhs - --- | Lint the RHS of a join point with expected join arity of @n@ (see Note --- [Join points] in "GHC.Core"). -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv) -lintJoinLams join_arity enforce rhs - = go join_arity rhs - where - go 0 expr = lintCoreExpr expr - go n (Lam var body) = lintLambda var $ go (n-1) body - go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas - = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs - | otherwise -- Future join point, not yet eta-expanded - = markAllJoinsBad $ lintCoreExpr expr - -- Body of lambda is not a tail position - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty uf - | isStableUnfolding uf - , Just rhs <- maybeUnfoldingTemplate uf - = do { ty <- fst <$> (if isCompulsoryUnfolding uf - then noFixedRuntimeRepChecks $ lintRhs bndr rhs - -- ^^^^^^^^^^^^^^^^^^^^^^^ - -- See Note [Checking for representation polymorphism] - else lintRhs bndr rhs) - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars - -{- -Note [Checking for INLINE loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very suspicious if a strong loop breaker is marked INLINE. - -However, the desugarer generates instance methods with INLINE pragmas -that form a mutually recursive group. Only after a round of -simplification are they unravelled. So we suppress the test for -the desugarer. - -Note [Checking for representation polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We ordinarily want to check for bad representation polymorphism. See -Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* -want to do this in a compulsory unfolding. Compulsory unfoldings arise -only internally, for things like newtype wrappers, dictionaries, and -(notably) unsafeCoerce#. These might legitimately be representation-polymorphic; -indeed representation-polymorphic unfoldings are a primary reason for the -very existence of compulsory unfoldings (we can't compile code for -the original, representation-polymorphic, binding). - -It is vitally important that we do representation polymorphism checks *after* -performing the unfolding, but not beforehand. This is all safe because -we will check any unfolding after it has been unfolded; checking the -unfolding beforehand is merely an optimization, and one that actively -hurts us here. - -Note [Linting of runRW#] -~~~~~~~~~~~~~~~~~~~~~~~~ -runRW# has some very special behavior (see Note [runRW magic] in -GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing -join points in its argument. For example, this is fine: - - join j x = ... - in runRW# (\s. case v of - A -> j 3 - B -> j 4) - -Usually those calls to the join point 'j' would not be valid tail calls, -because they occur in a function argument. But in the case of runRW# -they are fine, because runRW# (\s.e) behaves operationally just like e. -(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) - -In the case that the continuation is /not/ a lambda we simply disable this -special behaviour. For example, this is /not/ fine: - - join j = ... - in runRW# @r @ty (jump j) - - - -************************************************************************ -* * -\subsection[lintCoreExpr]{lintCoreExpr} -* * -************************************************************************ --} - --- Linted things: substitution applied, and type is linted -type LintedType = Type -type LintedKind = Kind -type LintedCoercion = Coercion -type LintedTyCoVar = TyCoVar -type LintedId = Id - --- | Lint an expression cast through the given coercion, returning the type --- resulting from the cast. -lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType -lintCastExpr expr expr_ty co - = do { co' <- lintCoercion co - ; let (Pair from_ty to_ty, role) = coercionKindRole co' - ; checkValueType to_ty $ - text "target of cast" <+> quotes (ppr co') - ; lintRole co' Representational role - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv) --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] - -lintCoreExpr (Var var) - = do - var_pair@(var_ty, _) <- lintIdOcc var 0 - checkCanEtaExpand (Var var) [] var_ty - return var_pair - -lintCoreExpr (Lit lit) - = return (literalType lit, zeroUE) - -lintCoreExpr (Cast expr co) - = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr - to_ty <- lintCastExpr expr expr_ty co - return (to_ty, ue) - -lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). - -lintCoreExpr (Let (NonRec tv (Type ty)) body) - | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- lintType ty - ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendTvSubstL tv ty' $ - addLoc (BodyOfLetRec [tv]) $ - lintCoreExpr body } } - -lintCoreExpr (Let (NonRec bndr rhs) body) - | isId bndr - = do { -- First Lint the RHS, before bringing the binder into scope - (rhs_ty, let_ue) <- lintRhs bndr rhs - - -- See Note [Multiplicity of let binders] in Var - -- Now lint the binder - ; lintBinder LetBind bndr $ \bndr' -> - do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr e@(Let (Rec pairs) body) - = do { -- Check that the list of pairs is non-empty - checkL (not (null pairs)) (emptyRec e) - - -- Check that there are no duplicated binders - ; let (_, dups) = removeDups compare bndrs - ; checkL (null dups) (dupVars dups) - - -- Check that either all the binders are joins, or none - ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ - mkInconsistentRecMsg bndrs - - -- See Note [Multiplicity of let binders] in Var - ; ((body_type, body_ue), ues) <- - lintRecBindings NotTopLevel pairs $ \ bndrs' -> - lintLetBody bndrs' body - ; return (body_type, body_ue `addUE` scaleUE Many (foldr1 addUE ues)) } - where - bndrs = map fst pairs - -lintCoreExpr e@(App _ _) - | Var fun <- fun - , fun `hasKey` runRWKey - -- N.B. we may have an over-saturated application of the form: - -- runRW (\s -> \x -> ...) y - , ty_arg1 : ty_arg2 : arg3 : rest <- args - = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 - ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 - -- See Note [Linting of runRW#] - ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) - lintRunRWCont expr@(Lam _ _) = - lintJoinLams 1 (Just fun) expr - lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other - -- TODO: Look through ticks? - ; (arg3_ty, ue3) <- lintRunRWCont arg3 - ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3 - ; lintCoreArgs app_ty rest } - - | otherwise - = do { fun_pair <- lintCoreFun fun (length args) - ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args - ; checkCanEtaExpand fun args app_ty - ; return app_pair} - where - (fun, args, _source_ticks) = collectArgsTicks tickishFloatable e - -- We must look through source ticks to avoid #21152, for example: - -- - -- reallyUnsafePtrEquality - -- = \ @a -> - -- (src reallyUnsafePtrEquality#) - -- @Lifted @a @Lifted @a - -- - -- To do this, we use `collectArgsTicks tickishFloatable` to match - -- the eta expansion behaviour, as per Note [Eta expansion and source notes] - -- in GHC.Core.Opt.Arity. - -lintCoreExpr (Lam var expr) - = markAllJoinsBad $ - lintLambda var $ lintCoreExpr expr - -lintCoreExpr (Case scrut var alt_ty alts) - = lintCaseExpr scrut var alt_ty alts - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = failWithL (text "Type found as expression" <+> ppr ty) - -lintCoreExpr (Coercion co) - = do { co' <- addLoc (InCo co) $ - lintCoercion co - ; return (coercionType co', zeroUE) } - ----------------------- -lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM (LintedType, UsageEnv) -- returns type of the *variable* -lintIdOcc var nargs - = addLoc (OccOf var) $ - do { checkL (isNonCoVarId var) - (text "Non term variable" <+> ppr var) - -- See GHC.Core Note [Variable occurrences in Core] - - -- Check that the type of the occurrence is the same - -- as the type of the binding site. The inScopeIds are - -- /un-substituted/, so this checks that the occurrence type - -- is identical to the binder type. - -- This makes things much easier for things like: - -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... - -- The "::Maybe a" on the occurrence is referring to the /outer/ a. - -- If we compared /substituted/ types we'd risk comparing - -- (Maybe a) from the binding site with bogus (Maybe a1) from - -- the occurrence site. Comparing un-substituted types finesses - -- this altogether - ; (bndr, linted_bndr_ty) <- lookupIdInScope var - ; let occ_ty = idType var - bndr_ty = idType bndr - ; ensureEqTys occ_ty bndr_ty $ - mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty - - -- Check for a nested occurrence of the StaticPtr constructor. - -- See Note [Checking StaticPtrs]. - ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ - checkL (idName var /= makeStaticName) $ - text "Found makeStatic nested in an expression" - - ; checkDeadIdOcc var - ; checkJoinOcc var nargs - - ; usage <- varCallSiteUsage var - - ; return (linted_bndr_ty, usage) } - -lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM (LintedType, UsageEnv) -- Returns type of the *function* -lintCoreFun (Var var) nargs - = lintIdOcc var nargs - -lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; - -- See Note [Beta redexes] - | nargs /= 0 - = lintLambda var $ lintCoreFun body (nargs - 1) - -lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr ------------------- -lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) -lintLambda var lintBody = - addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { (body_ty, ue) <- lintBody - ; ue' <- checkLinearity ue var' - ; return (mkLamType var' body_ty, ue') } ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () - ------------------- -lintJoinBndrType :: LintedType -- Type of the body - -> LintedId -- Possibly a join Id - -> LintM () --- Checks that the return type of a join Id matches the body --- E.g. join j x = rhs in body --- The type of 'rhs' must be the same as the type of 'body' -lintJoinBndrType body_ty bndr - | Just arity <- isJoinId_maybe bndr - , let bndr_ty = idType bndr - , (bndrs, res) <- splitPiTys bndr_ty - = checkL (length bndrs >= arity - && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ - hang (text "Join point returns different type than body") - 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) - , text "Join arity:" <+> ppr arity - , text "Body type:" <+> ppr body_ty ]) - | otherwise - = return () - -checkJoinOcc :: Id -> JoinArity -> LintM () --- Check that if the occurrence is a JoinId, then so is the --- binding site, and it's a valid join Id -checkJoinOcc var n_args - | Just join_arity_occ <- isJoinId_maybe var - = do { mb_join_arity_bndr <- lookupJoinId var - ; case mb_join_arity_bndr of { - Nothing -> -- Binder is not a join point - do { join_set <- getValidJoins - ; addErrL (text "join set " <+> ppr join_set $$ - invalidJoinOcc var) } ; - - Just join_arity_bndr -> - - do { checkL (join_arity_bndr == join_arity_occ) $ - -- Arity differs at binding site and occurrence - mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ - - ; checkL (n_args == join_arity_occ) $ - -- Arity doesn't match #args - mkBadJumpMsg var join_arity_occ n_args } } } - - | otherwise - = return () - --- | This function checks that we are able to perform eta expansion for --- functions with no binding, in order to satisfy invariant I3 --- from Note [Representation polymorphism invariants] in GHC.Core. -checkCanEtaExpand :: CoreExpr -- ^ the function (head of the application) we are checking - -> [CoreArg] -- ^ the arguments to the application - -> LintedType -- ^ the instantiated type of the overall application - -> LintM () -checkCanEtaExpand (Var fun_id) args app_ty - | hasNoBinding fun_id - = checkL (null bad_arg_tys) err_msg - where - arity :: Arity - arity = idArity fun_id - - nb_val_args :: Int - nb_val_args = count isValArg args - - -- Check the remaining argument types, past the - -- given arguments and up to the arity of the 'Id'. - -- Returns the types that couldn't be determined to have - -- a fixed RuntimeRep. - check_args :: [Type] -> [Type] - check_args = go (nb_val_args + 1) - where - go :: Int -- index of the argument (starting from 1) - -> [Type] -- arguments - -> [Type] -- value argument types that could not be - -- determined to have a fixed runtime representation - go i _ - | i > arity - = [] - go _ [] - -- The Arity of an Id should never exceed the number of value arguments - -- that can be read off from the Id's type. - -- See Note [Arity and function types] in GHC.Types.Id.Info. - = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type" - $ vcat - [ text "fun_id =" <+> ppr fun_id - , text "arity =" <+> ppr arity - , text "app_ty =" <+> ppr app_ty - , text "args = " <+> ppr args - , text "nb_val_args =" <+> ppr nb_val_args ] - go i (ty : bndrs) - | typeHasFixedRuntimeRep ty - = go (i+1) bndrs - | otherwise - = ty : go (i+1) bndrs - - bad_arg_tys :: [Type] - bad_arg_tys = check_args . map fst $ getRuntimeArgTys app_ty - -- We use 'getRuntimeArgTys' to find all the argument types, - -- including those hidden under newtypes. For example, - -- if `FunNT a b` is a newtype around `a -> b`, then - -- when checking - -- - -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c - -- - -- we should check that the instantiations of BOTH `a` AND `b` - -- have a fixed runtime representation. - - err_msg :: SDoc - err_msg - = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id) - , text "The following type" <> plural bad_arg_tys - <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:" - , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ] - - ppr_ty_ki :: Type -> SDoc - ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty) -checkCanEtaExpand _ _ _ - = return () - --- Check that the usage of var is consistent with var itself, and pop the var --- from the usage environment (this is important because of shadowing). -checkLinearity :: UsageEnv -> Var -> LintM UsageEnv -checkLinearity body_ue lam_var = - case varMultMaybe lam_var of - Just mult -> do ensureSubUsage lhs mult (err_msg mult) - return $ deleteUE body_ue lam_var - Nothing -> return body_ue -- A type variable - where - lhs = lookupUE body_ue lam_var - err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var - $$ ppr lhs <+> text "⊈" <+> ppr mult - -{- -Note [No alternatives lint check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions with no alternatives are odd beasts, and it would seem -like they would worth be looking at in the linter (cf #10180). We -used to check two things: - -* exprIsHNF is false: it would *seem* to be terribly wrong if - the scrutinee was already in head normal form. - -* exprIsDeadEnd is true: we should be able to see why GHC believes the - scrutinee is diverging for sure. - -It was already known that the second test was not entirely reliable. -Unfortunately (#13990), the first test turned out not to be reliable -either. Getting the checks right turns out to be somewhat complicated. - -For example, suppose we have (comment 8) - - data T a where - TInt :: T Int - - absurdTBool :: T Bool -> a - absurdTBool v = case v of - - data Foo = Foo !(T Bool) - - absurdFoo :: Foo -> a - absurdFoo (Foo x) = absurdTBool x - -GHC initially accepts the empty case because of the GADT conditions. But then -we inline absurdTBool, getting - - absurdFoo (Foo x) = case x of - -x is in normal form (because the Foo constructor is strict) but the -case is empty. To avoid this problem, GHC would have to recognize -that matching on Foo x is already absurd, which is not so easy. - -More generally, we don't really know all the ways that GHC can -lose track of why an expression is bottom, so we shouldn't make too -much fuss when that happens. - - -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in GHC.Core). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - -************************************************************************ -* * -\subsection[lintCoreArgs]{lintCoreArgs} -* * -************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. --} - - -lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv) -lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args - -lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv) -lintCoreArg (fun_ty, ue) (Type arg_ty) - = do { checkL (not (isCoercionTy arg_ty)) - (text "Unnecessary coercion-to-type injection:" - <+> ppr arg_ty) - ; arg_ty' <- lintType arg_ty - ; res <- lintTyApp fun_ty arg_ty' - ; return (res, ue) } - -lintCoreArg (fun_ty, fun_ue) arg - = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg - -- See Note [Representation polymorphism invariants] in GHC.Core - ; flags <- getLintFlags - - ; when (lf_check_fixed_rep flags) $ - -- Only check that 'arg_ty' has a fixed RuntimeRep - -- if 'lf_check_fixed_rep' is on. - do { checkL (typeHasFixedRuntimeRep arg_ty) - (text "Argument does not have a fixed runtime representation" - <+> ppr arg <+> dcolon - <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) - - ; checkL (mightBeLiftedType arg_ty || exprOkForSpeculation arg) - (mkLetAppMsg arg) } - - ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } - ------------------ -lintAltBinders :: UsageEnv - -> Var -- Case binder - -> LintedType -- Scrutinee type - -> LintedType -- Constructor type - -> [(Mult, OutVar)] -- Binders - -> LintM UsageEnv --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] - = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) - ; return rhs_ue } -lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) - | isTyVar bndr - = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } - | otherwise - = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE - -- We can pass zeroUE to lintValApp because we ignore its usage - -- calculation and compute it in the call for checkCaseLinearity below. - ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr - ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } - --- | Implements the case rules for linearity -checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv -checkCaseLinearity ue case_bndr var_w bndr = do - ensureSubUsage lhs rhs err_msg - lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr) - return $ deleteUE ue bndr - where - lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) - rhs = case_bndr_w `mkMultMul` var_w - err_msg = (text "Linearity failure in variable:" <+> ppr bndr - $$ ppr lhs <+> text "⊈" <+> ppr rhs - $$ text "Computed by:" - <+> text "LHS:" <+> lhs_formula - <+> text "RHS:" <+> rhs_formula) - lhs_formula = ppr bndr_usage <+> text "+" - <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) - rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w - case_bndr_w = varMult case_bndr - case_bndr_usage = lookupUE ue case_bndr - bndr_usage = lookupUE ue bndr - - - ------------------ -lintTyApp :: LintedType -> LintedType -> LintM LintedType -lintTyApp fun_ty arg_ty - | Just (tv,body_ty) <- splitForAllTyCoVar_maybe fun_ty - = do { lintTyKind tv arg_ty - ; in_scope <- getInScope - -- substTy needs the set of tyvars in scope to avoid generating - -- uniques that are already in scope. - -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } - - | otherwise - = failWithL (mkTyAppMsg fun_ty arg_ty) - ------------------ - --- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ --- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the --- 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 - = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) - ; let app_ue = addUE fun_ue (scaleUE w arg_ue) - ; return (res_ty', app_ue) } - | otherwise - = failWithL err2 - where - err2 = mkNonFunAppMsg fun_ty arg_ty arg - -lintTyKind :: OutTyVar -> LintedType -> LintM () --- Both args have had substitution applied - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintTyKind tyvar arg_ty - = unless (arg_kind `eqType` tyvar_kind) $ - addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) - where - tyvar_kind = tyVarKind tyvar - arg_kind = typeKind arg_ty - -{- -************************************************************************ -* * -\subsection[lintCoreAlts]{lintCoreAlts} -* * -************************************************************************ --} - -lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv) -lintCaseExpr scrut var alt_ty alts = - do { let e = Case scrut var alt_ty alts -- Just for error messages - - -- Check the scrutinee - ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut - -- See Note [Join points are less general than the paper] - -- in GHC.Core - ; let scrut_mult = varMult var - - ; alt_ty <- addLoc (CaseTy scrut) $ - lintValueType alt_ty - ; var_ty <- addLoc (IdTy var) $ - lintValueType (idType var) - - -- We used to try to check whether a case expression with no - -- alternatives was legitimate, but this didn't work. - -- See Note [No alternatives lint check] for details. - - -- Check that the scrutinee is not a floating-point type - -- if there are any literal alternatives - -- See GHC.Core Note [Case expression invariants] item (5) - -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold - ; let isLitPat (Alt (LitAlt _) _ _) = True - isLitPat _ = False - ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts) - (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." - $$ text "scrut" <+> ppr scrut) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn - , isAlgTyCon tycon - , not (isAbstractTyCon tycon) - , null (tyConDataCons tycon) - , not (exprIsDeadEnd scrut) - -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) - -- This can legitimately happen for type families - $ return () - _otherwise -> return () - - -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - - ; subst <- getTCvSubst - ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- See GHC.Core Note [Case expression invariants] item (7) - - ; lintBinder CaseBind var $ \_ -> - do { -- Check the alternatives - ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts - ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues - ; checkCaseAlts e scrut_ty alts - ; return (alt_ty, case_ue) } } - -checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () --- a) Check that the alts are non-empty --- b1) Check that the DEFAULT comes first, if it exists --- b2) Check that the others are in increasing order --- c) Check that there's a default for infinite types --- NB: Algebraic cases are not necessarily exhaustive, because --- the simplifier correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - -- See GHC.Core Note [Case expression invariants] item (2) - - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - -- See GHC.Core Note [Case expression invariants] item (3) - - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) } - where - (con_alts, maybe_deflt) = findDefault alts - - -- Check that successive alternatives have strictly increasing tags - increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag _ = True - - non_deflt (Alt DEFAULT _ _) = False - non_deflt _ = True - - is_infinite_ty = case tyConAppTyCon_maybe ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - -lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv -lintAltExpr expr ann_ty - = do { (actual_ty, ue) <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) - ; return ue } - -- See GHC.Core Note [Case expression invariants] item (6) - -lintCoreAlt :: Var -- Case binder - -> LintedType -- Type of scrutinee - -> Mult -- Multiplicity of scrutinee - -> LintedType -- Type of the alternative - -> CoreAlt - -> LintM UsageEnv --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; lintAltExpr rhs alt_ty } - -lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { lintL (null args) (mkDefaultArgsMsg args) - ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; lintAltExpr rhs alt_ty } - where - lit_ty = literalType lit - -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) - | isNewTyCon (dataConTyCon con) - = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) - | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ do - { -- First instantiate the universally quantified - -- type variables of the data constructor - -- 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 - -- See Note [Validating multiplicities in a case] - ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } - - -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do - { - rhs_ue <- lintAltExpr rhs alt_ty - ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args')) - ; return $ deleteUE rhs_ue' case_bndr - } - } - - | otherwise -- Scrut-ty is wrong shape - = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) - -{- -Note [Validating multiplicities in a case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'MkT :: a %m -> T m a'. -If we are validating 'case (x :: T Many a) of MkT y -> ...', -we have to substitute m := Many in the type of MkT - in particular, -y can be used Many times and that expression would still be linear in x. -We do this by looking at con_payload_ty, which is the type of the datacon -applied to the surrounding arguments. -Testcase: linear/should_compile/MultConstructor - -Data constructors containing existential tyvars will then have -Named binders, which are always multiplicity Many. -Testcase: indexed-types/should_compile/GADT1 --} - -lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () -lintLinearBinder doc actual_usage described_usage - = ensureSubMult actual_usage described_usage err_msg - where - err_msg = (text "Multiplicity of variable does not agree with its context" - $$ doc - $$ ppr actual_usage - $$ text "Annotation:" <+> ppr described_usage) - -{- -************************************************************************ -* * -\subsection[lint-types]{Types} -* * -************************************************************************ --} - --- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a -lintBinder site var linterF - | isTyCoVar var = lintTyCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel 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 <- getTCvSubst - ; kind' <- lintType (varType tcv) - ; let tcv' = uniqAway (getTCvInScope subst) $ - setVarType tcv kind' - subst' = extendTCvSubstWithClone subst tcv tcv' - ; when (isCoVar tcv) $ - lintL (isCoVarType kind') - (text "CoVar with non-coercion type:" <+> pprTyVar tcv) - ; updateTCvSubst subst' (thing_inside tcv') } - -lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a -lintIdBndrs top_lvl ids thing_inside - = go ids thing_inside - where - go :: [Id] -> ([Id] -> LintM a) -> LintM a - go [] thing_inside = thing_inside [] - go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> - go ids $ \ids' -> - thing_inside (id' : ids') - -lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules -lintIdBndr top_lvl bind_site id thing_inside - = assertPpr (isId id) (ppr id) $ - do { flags <- getLintFlags - ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (text "Non-local Id binder" <+> ppr id) - -- See Note [Checking for global Ids] - - -- Check that if the binder is nested, it is not marked as exported - ; checkL (not (isExportedId id) || is_top_lvl) - (mkNonTopExportedMsg id) - - -- Check that if the binder is nested, it does not have an external name - ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) - (mkNonTopExternalNameMsg id) - - -- See Note [Representation polymorphism invariants] in GHC.Core - ; lintL (isJoinId id || not (lf_check_fixed_rep flags) - || typeHasFixedRuntimeRep id_ty) $ - text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> - parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) - - -- Check that a join-id is a not-top-level let-binding - ; when (isJoinId id) $ - checkL (not is_top_lvl && is_let_bind) $ - mkBadJoinBindMsg id - - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType id_ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - - -- Check that the lambda binder has no value or OtherCon unfolding. - -- See #21496 - ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") - - ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty) - - ; addInScopeId id linted_ty $ - thing_inside (setIdType id linted_ty) } - where - id_ty = idType id - - is_top_lvl = isTopLevel top_lvl - is_let_bind = case bind_site of - LetBind -> True - _ -> False - -{- -%************************************************************************ -%* * - Types -%* * -%************************************************************************ --} - -lintValueType :: Type -> LintM LintedType --- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] -lintValueType ty - = addLoc (InType ty) $ - do { ty' <- lintType ty - ; let sk = typeKind ty' - ; lintL (classifiesTypeWithValues sk) $ - hang (text "Ill-kinded type:" <+> ppr ty) - 2 (text "has kind:" <+> ppr sk) - ; return ty' } - -checkTyCon :: TyCon -> LintM () -checkTyCon tc - = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) - -------------------- -lintType :: Type -> LintM LintedType - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintType (TyVarTy tv) - | not (isTyVar tv) - = failWithL (mkBadTyVarMsg tv) - - | otherwise - = do { subst <- getTCvSubst - ; case lookupTyVar subst tv of - Just linted_ty -> return linted_ty - - -- In GHCi we may lint an expression with a free - -- type variable. Then it won't be in the - -- substitution, but it should be in scope - Nothing | tv `isInScope` subst - -> return (TyVarTy tv) - | otherwise - -> failWithL $ - hang (text "The type variable" <+> pprBndr LetBind tv) - 2 (text "is out of scope") - } - -lintType ty@(AppTy t1 t2) - | TyConApp {} <- t1 - = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty - | otherwise - = do { t1' <- lintType t1 - ; t2' <- lintType t2 - ; lint_ty_app ty (typeKind t1') [t2'] - ; return (AppTy t1' t2') } - -lintType ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags - ; lintTySynFamApp report_unsat ty tc tys } - - | isFunTyCon tc - , tys `lengthIs` 5 - -- 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)) - - | otherwise -- Data types, data families, primitive types - = do { checkTyCon tc - ; tys' <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - --- arrows can related *unlifted* kinds, so this has to be separate from --- a dependent forall. -lintType ty@(FunTy af tw t1 t2) - = do { t1' <- lintType t1 - ; t2' <- lintType t2 - ; tw' <- lintType tw - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw' - ; return (FunTy af tw' t1' t2') } - -lintType ty@(ForAllTy (Bndr tcv vis) body_ty) - | not (isTyCoVar tcv) - = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty) - | otherwise - = lintTyCoBndr tcv $ \tcv' -> - do { body_ty' <- lintType body_ty - ; lintForAllBody tcv' body_ty' - - ; when (isCoVar tcv) $ - lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $ - text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) - -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] - -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo] - - ; return (ForAllTy (Bndr tcv' vis) body_ty') } - -lintType ty@(LitTy l) - = do { lintTyLit l; return ty } - -lintType (CastTy ty co) - = do { ty' <- lintType ty - ; co' <- lintStarCoercion co - ; let tyk = typeKind ty' - cok = coercionLKind co' - ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok) - ; return (CastTy ty' co') } - -lintType (CoercionTy co) - = do { co' <- lintCoercion co - ; return (CoercionTy co') } - ------------------ -lintForAllBody :: LintedTyCoVar -> LintedType -> LintM () --- Do the checks for the body of a forall-type -lintForAllBody tcv body_ty - = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty) - - -- For type variables, check for skolem escape - -- See Note [Phantom type variables in kinds] in GHC.Core.Type - -- The kind of (forall cv. th) is liftedTypeKind, so no - -- need to check for skolem-escape in the CoVar case - ; let body_kind = typeKind body_ty - ; when (isTyVar tcv) $ - case occCheckExpand [tcv] body_kind of - Just {} -> return () - Nothing -> failWithL $ - hang (text "Variable escape in forall:") - 2 (vcat [ text "tyvar:" <+> ppr tcv - , text "type:" <+> ppr body_ty - , text "kind:" <+> ppr body_kind ]) - } - ------------------ -lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType --- The TyCon is a type synonym or a type family (not a data family) --- See Note [Linting type synonym applications] --- c.f. GHC.Tc.Validity.check_syn_tc_app -lintTySynFamApp report_unsat ty tc tys - | report_unsat -- Report unsaturated only if report_unsat is on - , tys `lengthLessThan` tyConArity tc - = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) - - -- Deal with type synonyms - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { -- Kind-check the argument types, but without reporting - -- un-saturated type families/synonyms - tys' <- setReportUnsat False (mapM lintType tys) - - ; when report_unsat $ - do { _ <- lintType expanded_ty - ; return () } - - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - - -- Otherwise this must be a type family - | otherwise - = do { tys' <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - ------------------ --- Confirms that a type is really TYPE r or Constraint -checkValueType :: LintedType -> SDoc -> LintM () -checkValueType ty doc - = lintL (classifiesTypeWithValues kind) - (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ - text "when checking" <+> doc) - where - kind = typeKind ty - ------------------ -lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () --- If you edit this function, you may need to update the GHC formalism --- 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)) } - 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 ] - ------------------ -lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () -lint_ty_app ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr ty)) k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = text "Negative type literal:" <+> integer n -lintTyLit (StrTyLit _) = return () -lintTyLit (CharTyLit _) = return () - -lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () --- (lint_app d fun_kind arg_tys) --- We have an application (f arg_ty1 .. arg_tyn), --- where f :: fun_kind - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lint_app doc kfn arg_tys - = do { in_scope <- getInScope - -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; _ <- foldlM (go_app in_scope) kfn arg_tys - ; return () } - where - fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg types =" <+> ppr arg_tys) - , extra ] - - go_app in_scope kfn ta - | Just kfn' <- coreView kfn - = go_app in_scope kfn' ta - - go_app _ fun_kind@(FunTy _ _ kfa kfb) ta - = do { let ka = typeKind ta - ; unless (ka `eqType` kfa) $ - addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; return kfb } - - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta - = do { let kv_kind = varType kv - ka = typeKind ta - ; unless (ka `eqType` kv_kind) $ - addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ - ppr ta <+> dcolon <+> ppr ka))) - ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } - - go_app _ kfn ta - = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) - -{- ********************************************************************* -* * - Linting rules -* * -********************************************************************* -} - -lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM () -lintCoreRule _ _ (BuiltinRule {}) - = return () -- Don't bother - -lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs }) - = lintBinders LambdaBind bndrs $ \ _ -> - do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args - ; (rhs_ty, _) <- case isJoinId_maybe fun of - Just join_arity - -> do { checkL (args `lengthIs` join_arity) $ - mkBadJoinPointRuleMsg fun join_arity rule - -- See Note [Rules for join points] - ; lintCoreExpr rhs } - _ -> markAllJoinsBad $ lintCoreExpr rhs - ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty - , text "rhs type:" <+> ppr rhs_ty - , text "fun_ty:" <+> ppr fun_ty ]) - ; let bad_bndrs = filter is_bad_bndr bndrs - - ; checkL (null bad_bndrs) - (rule_doc <+> text "unbound" <+> ppr bad_bndrs) - -- See Note [Linting rules] - } - where - rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - - lhs_fvs = exprsFreeVars args - rhs_fvs = exprFreeVars rhs - - is_bad_bndr :: Var -> Bool - -- See Note [Unbound RULE binders] in GHC.Core.Rules - is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) - && bndr `elemVarSet` rhs_fvs - && isNothing (isReflCoVar_maybe bndr) - - -{- Note [Linting rules] -~~~~~~~~~~~~~~~~~~~~~~~ -It's very bad if simplifying a rule means that one of the template -variables (ru_bndrs) that /is/ mentioned on the RHS becomes -not-mentioned in the LHS (ru_args). How can that happen? Well, in #10602, -SpecConstr stupidly constructed a rule like - - forall x,c1,c2. - f (x |> c1 |> c2) = .... - -But simplExpr collapses those coercions into one. (Indeed in #10602, -it collapsed to the identity and was removed altogether.) - -We don't have a great story for what to do here, but at least -this check will nail it. - -NB (#11643): it's possible that a variable listed in the -binders becomes not-mentioned on both LHS and RHS. Here's a silly -example: - RULE forall x y. f (g x y) = g (x+1) (y-1) -And suppose worker/wrapper decides that 'x' is Absent. Then -we'll end up with - RULE forall x y. f ($gw y) = $gw (x+1) -This seems sufficiently obscure that there isn't enough payoff to -try to trim the forall'd binder list. - -Note [Rules for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A join point cannot be partially applied. However, the left-hand side of a rule -for a join point is effectively a *pattern*, not a piece of code, so there's an -argument to be made for allowing a situation like this: - - join $sj :: Int -> Int -> String - $sj n m = ... - j :: forall a. Eq a => a -> a -> String - {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} - j @a $dEq x y = ... - -Applying this rule can't turn a well-typed program into an ill-typed one, so -conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact -the simplifier would have to in order to deal with the RHS. So we take a -conservative view and don't allow undersaturated rules for join points. See -Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. --} - -{- -************************************************************************ -* * - Linting coercions -* * -************************************************************************ --} - -{- Note [Asymptotic efficiency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting coercions (and types actually) we return a linted -(substituted) coercion. Then we often have to take the coercionKind of -that returned coercion. If we get long chains, that can be asymptotically -inefficient, notably in -* TransCo -* InstCo -* NthCo (cf #9233) -* LRCo - -But the code is simple. And this is only Lint. Let's wait to see if -the bad perf bites us in practice. - -A solution would be to return the kind and role of the coercion, -as well as the linted coercion. Or perhaps even *only* the kind and role, -which is what used to happen. But that proved tricky and error prone -(#17923), so now we return the coercion. --} - - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: InCoercion -> LintM LintedCoercion -lintStarCoercion g - = do { g' <- lintCoercion g - ; let Pair t1 t2 = coercionKind g' - ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) - ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) - ; lintRole g Nominal (coercionRole g) - ; return g' } - -lintCoercion :: InCoercion -> LintM LintedCoercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) - 2 (text "With offending type:" <+> ppr (varType cv))) - - | otherwise - = do { subst <- getTCvSubst - ; case lookupCoVar subst cv of - Just linted_co -> return linted_co ; - Nothing - | cv `isInScope` subst - -> return (CoVarCo cv) - | otherwise - -> - -- lintCoBndr always extends the substitition - failWithL $ - hang (text "The coercion variable" <+> pprBndr LetBind cv) - 2 (text "is out of scope") - } - - -lintCoercion (Refl ty) - = do { ty' <- lintType ty - ; return (Refl ty') } - -lintCoercion (GRefl r ty MRefl) - = do { ty' <- lintType ty - ; return (GRefl r ty' MRefl) } - -lintCoercion (GRefl r ty (MCo co)) - = do { ty' <- lintType ty - ; co' <- lintCoercion co - ; let tk = typeKind ty' - tl = coercionLKind co' - ; ensureEqTys tk tl $ - hang (text "GRefl coercion kind mis-match:" <+> ppr co) - 2 (vcat [ppr ty', ppr tk, ppr tl]) - ; lintRole co' Nominal (coercionRole 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) - -- All saturated TyConAppCos should be FunCos - - | Just {} <- synTyConDefn_maybe tc - = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) - - | otherwise - = do { checkTyCon tc - ; cos' <- mapM lintCoercion cos - ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos') - ; lint_co_app co (tyConKind tc) (map pFst co_kinds) - ; lint_co_app co (tyConKind tc) (map pSnd co_kinds) - ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles - ; return (TyConAppCo r tc cos') } - -lintCoercion co@(AppCo co1 co2) - | TyConAppCo {} <- co1 - = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) - | Just (TyConApp {}, _) <- isReflCo_maybe co1 - = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) - | otherwise - = do { co1' <- lintCoercion co1 - ; co2' <- lintCoercion co2 - ; let (Pair lk1 rk1, r1) = coercionKindRole co1' - (Pair lk2 rk2, r2) = coercionKindRole co2' - ; lint_co_app co (typeKind lk1) [lk2] - ; lint_co_app co (typeKind rk1) [rk2] - - ; if r1 == Phantom - then lintL (r2 == Phantom || r2 == Nominal) - (text "Second argument in AppCo cannot be R:" $$ - ppr co) - else lintRole co Nominal r2 - - ; return (AppCo co1' co2') } - ----------- -lintCoercion co@(ForAllCo tcv kind_co body_co) - | not (isTyCoVar tcv) - = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) - | otherwise - = do { kind_co' <- lintStarCoercion kind_co - ; lintTyCoBndr tcv $ \tcv' -> - do { body_co' <- lintCoercion body_co - ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ - text "Kind mis-match in ForallCo" <+> ppr co - - -- Assuming kind_co :: k1 ~ k2 - -- Need to check that - -- (forall (tcv:k1). lty) and - -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) - -- are both well formed. Easiest way is to call lintForAllBody - -- for each; there is actually no need to do the funky substitution - ; let Pair lty rty = coercionKind body_co' - ; lintForAllBody tcv' lty - ; lintForAllBody tcv' rty - - ; when (isCoVar tcv) $ - lintL (almostDevoidCoVarOfCo tcv body_co) $ - text "Covar can only appear in Refl and GRefl: " <+> ppr co - -- See "last wrinkle" in GHC.Core.Coercion - -- Note [Unused coercion variable in ForAllCo] - -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] - - ; return (ForAllCo tcv' kind_co' body_co') } } - -lintCoercion co@(FunCo r cow co1 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 - ; 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)) - ; let expected_mult_role = case r of - Phantom -> Phantom - _ -> Nominal - ; lintRole cow expected_mult_role (coercionRole cow) - ; return (FunCo r cow' co1' co2') } - --- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) - = do { ty1' <- lintType ty1 - ; ty2' <- lintType ty2 - ; let k1 = typeKind ty1' - k2 = typeKind ty2' - ; prov' <- lint_prov k1 k2 prov - - ; when (r /= Phantom && classifiesTypeWithValues k1 - && classifiesTypeWithValues k2) - (checkTypes ty1 ty2) - - ; return (UnivCo prov' r ty1' ty2') } - where - report s = hang (text $ "Unsafe coercion: " ++ s) - 2 (vcat [ text "From:" <+> ppr ty1 - , text " To:" <+> ppr ty2]) - isUnBoxed :: PrimRep -> Bool - isUnBoxed = not . isGcPtrRep - - -- see #9122 for discussion of these checks - checkTypes t1 t2 - | allow_ill_kinded_univ_co prov - = return () -- Skip kind checks - | otherwise - = do { checkWarnL fixed_rep_1 - (report "left-hand type does not have a fixed runtime representation") - ; checkWarnL fixed_rep_2 - (report "right-hand type does not have a fixed runtime representation") - ; when (fixed_rep_1 && fixed_rep_2) $ - do { checkWarnL (reps1 `equalLength` reps2) - (report "between values with different # of reps") - ; zipWithM_ validateCoercion reps1 reps2 }} - where - fixed_rep_1 = typeHasFixedRuntimeRep t1 - fixed_rep_2 = typeHasFixedRuntimeRep t2 - - -- don't look at these unless lev_poly1/2 are False - -- Otherwise, we get #13458 - reps1 = typePrimRep t1 - reps2 = typePrimRep t2 - - -- CorePrep deliberately makes ill-kinded casts - -- e.g (case error @Int "blah" of {}) :: Int# - -- ==> (error @Int "blah") |> Unsafe Int Int# - -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind - allow_ill_kinded_univ_co _ = False - - validateCoercion :: PrimRep -> PrimRep -> LintM () - validateCoercion rep1 rep2 - = do { platform <- targetPlatform <$> getDynFlags - ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) - (report "between unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeB platform rep1 - == TyCon.primRepSizeB platform rep2) - (report "between unboxed values of different size") - ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) - (TyCon.primRepIsFloat rep2) - ; case fl of - Nothing -> addWarnL (report "between vector types") - Just False -> addWarnL (report "between float and integral values") - _ -> return () - } - - lint_prov k1 k2 (PhantomProv kco) - = do { kco' <- lintStarCoercion kco - ; lintRole co Phantom r - ; check_kinds kco' k1 k2 - ; return (PhantomProv kco') } - - lint_prov k1 k2 (ProofIrrelProv kco) - = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) - ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) - ; kco' <- lintStarCoercion kco - ; check_kinds kco k1 k2 - ; return (ProofIrrelProv kco') } - - lint_prov _ _ prov@(PluginProv _) = return prov - lint_prov _ _ prov@(CorePrepProv _) = return prov - - check_kinds kco k1 k2 - = do { let Pair k1' k2' = coercionKind kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - - -lintCoercion (SymCo co) - = do { co' <- lintCoercion co - ; return (SymCo co') } - -lintCoercion co@(TransCo co1 co2) - = do { co1' <- lintCoercion co1 - ; co2' <- lintCoercion co2 - ; let ty1b = coercionRKind co1' - ty2a = coercionLKind co2' - ; ensureEqTys ty1b ty2a - (hang (text "Trans coercion mis-match:" <+> ppr co) - 2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')])) - ; lintRole co (coercionRole co1) (coercionRole co2) - ; return (TransCo co1' co2') } - -lintCoercion the_co@(NthCo r0 n 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) - || (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)) }}} - -lintCoercion the_co@(LRCo lr co) - = do { co' <- lintCoercion co - ; let Pair s t = coercionKind co' - r = coercionRole co' - ; lintRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just _, Just _) -> return (LRCo lr co') - _ -> failWithL (hang (text "Bad LRCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg) - = do { co' <- lintCoercion co - ; arg' <- lintCoercion arg - ; let Pair t1 t2 = coercionKind co' - Pair s1 s2 = coercionKind arg' - - ; lintRole arg Nominal (coercionRole arg') - - ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of - -- forall over tvar - { (Just (tv1,_), Just (tv2,_)) - | typeKind s1 `eqType` tyVarKind tv1 - , typeKind s2 `eqType` tyVarKind tv2 - -> return (InstCo co' arg') - | otherwise - -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) - - ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of - -- forall over covar - { (Just (cv1, _), Just (cv2, _)) - | typeKind s1 `eqType` varType cv1 - , typeKind s2 `eqType` varType cv2 - , CoercionTy _ <- s1 - , CoercionTy _ <- s2 - -> return (InstCo co' arg') - | otherwise - -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co) - - ; _ -> failWithL (text "Bad argument of inst") }}} - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) - (bad_ax (text "index out of range")) - ; let CoAxBranch { cab_tvs = ktvs - , cab_cvs = cvs - , cab_roles = roles } = coAxiomNthBranch con ind - ; unless (cos `equalLength` (ktvs ++ cvs)) $ - bad_ax (text "lengths") - ; cos' <- mapM lintCoercion cos - ; subst <- getTCvSubst - ; let empty_subst = zapTCvSubst subst - ; _ <- foldlM check_ki (empty_subst, empty_subst) - (zip3 (ktvs ++ cvs) roles cos') - ; let fam_tc = coAxiomTyCon con - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch fam_tc bad_branch - Nothing -> return () - ; return (AxiomInstCo con ind cos') } - where - bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, arg') - = do { let Pair s' t' = coercionKind arg' - sk' = typeKind s' - tk' = typeKind t' - ; lintRole arg' role (coercionRole arg') - ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) - ktv_kind_r = substTy subst_r (tyVarKind ktv) - ; unless (sk' `eqType` ktv_kind_l) - (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) - ; unless (tk' `eqType` ktv_kind_r) - (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) - ; return (extendTCvSubst subst_l ktv s', - extendTCvSubst subst_r ktv t') } - -lintCoercion (KindCo co) - = do { co' <- lintCoercion co - ; return (KindCo co') } - -lintCoercion (SubCo co') - = do { co' <- lintCoercion co' - ; lintRole co' Nominal (coercionRole co') - ; return (SubCo co') } - -lintCoercion this@(AxiomRuleCo ax cos) - = do { cos' <- mapM lintCoercion cos - ; lint_roles 0 (coaxrAsmpRoles ax) cos' - ; case coaxrProves ax (map coercionKind cos') of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just _ -> return (AxiomRuleCo ax cos') } - where - err :: forall a. String -> [SDoc] -> LintM a - err m xs = failWithL $ - hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) - - lint_roles n (e : es) (co : cos) - | e == coercionRole co = lint_roles (n+1) es cos - | otherwise = err "Argument roles mismatch" - [ text "In argument:" <+> int (n+1) - , text "Expected:" <+> ppr e - , text "Found:" <+> ppr (coercionRole co) ] - lint_roles _ [] [] = return () - lint_roles n [] rs = err "Too many coercion arguments" - [ text "Expected:" <+> int n - , text "Provided:" <+> int (n + length rs) ] - - lint_roles n es [] = err "Not enough coercion arguments" - [ text "Expected:" <+> int (n + length es) - , text "Provided:" <+> int n ] - -lintCoercion (HoleCo h) - = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h - ; lintCoercion (CoVarCo (coHoleCoVar h)) } - -{- -************************************************************************ -* * - Axioms -* * -************************************************************************ --} - -lintAxioms :: Logger - -> DynFlags - -> SDoc -- ^ The source of the linted axioms - -> [CoAxiom Branched] - -> IO () -lintAxioms logger dflags what axioms = - displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ - initL dflags (defaultLintFlags dflags) [] $ - do { mapM_ lint_axiom axioms - ; let axiom_groups = groupWith coAxiomTyCon axioms - ; mapM_ lint_axiom_group axiom_groups } - -lint_axiom :: CoAxiom Branched -> LintM () -lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches - , co_ax_role = ax_role }) - = addLoc (InAxiom ax) $ - do { mapM_ (lint_branch tc) branch_list - ; extra_checks } - where - branch_list = fromBranches branches - - extra_checks - | isNewTyCon tc - = do { CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs_tys } - <- case branch_list of - [branch] -> return branch - _ -> failWithL (text "multi-branch axiom with newtype") - ; let ax_lhs = mkInfForAllTys tvs $ - mkTyConApp tc lhs_tys - nt_tvs = takeList tvs (tyConTyVars tc) - -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon - nt_lhs = mkInfForAllTys nt_tvs $ - mkTyConApp tc (mkTyVarTys nt_tvs) - -- See Note [Newtype eta] in GHC.Core.TyCon - ; lintL (ax_lhs `eqType` nt_lhs) - (text "Newtype axiom LHS does not match newtype definition") - ; lintL (null cvs) - (text "Newtype axiom binds coercion variables") - ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] - -- which is not about newtype axioms - (text "Newtype axiom has eta-tvs") - ; lintL (ax_role == Representational) - (text "Newtype axiom role not representational") - ; lintL (roles `equalLength` tvs) - (text "Newtype axiom roles list is the wrong length." $$ - text "roles:" <+> sep (map ppr roles)) - ; lintL (roles == takeList roles (tyConRoles tc)) - (vcat [ text "Newtype axiom roles do not match newtype tycon's." - , text "axiom roles:" <+> sep (map ppr roles) - , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) - } - - | isFamilyTyCon tc - = do { if | isTypeFamilyTyCon tc - -> lintL (ax_role == Nominal) - (text "type family axiom is not nominal") - - | isDataFamilyTyCon tc - -> lintL (ax_role == Representational) - (text "data family axiom is not representational") - - | otherwise - -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) - - ; mapM_ (lint_family_branch tc) branch_list } - - | otherwise - = addErrL (text "Axiom tycon is neither a newtype nor a family.") - -lint_branch :: TyCon -> CoAxBranch -> LintM () -lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs_args, cab_rhs = rhs }) - = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> - do { let lhs = mkTyConApp ax_tc lhs_args - ; lhs' <- lintType lhs - ; rhs' <- lintType rhs - ; let lhs_kind = typeKind lhs' - rhs_kind = typeKind rhs' - ; lintL (lhs_kind `eqType` rhs_kind) $ - hang (text "Inhomogeneous axiom") - 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ - text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } - --- these checks do not apply to newtype axioms -lint_family_branch :: TyCon -> CoAxBranch -> LintM () -lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs - , cab_incomps = incomps }) - = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) - (text "Type family axiom has eta-tvs") - ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) - (text "Quantified variable in family axiom unused in LHS") - ; lintL (all isTyFamFree lhs) - (text "Type family application on LHS of family axiom") - ; lintL (all (== Nominal) roles) - (text "Non-nominal role in family axiom" $$ - text "roles:" <+> sep (map ppr roles)) - ; lintL (null cvs) - (text "Coercion variables bound in family axiom") - ; forM_ incomps $ \ br' -> - lintL (not (compatibleBranches br br')) $ - hang (text "Incorrect incompatible branches:") - 2 (vcat [text "Branch:" <+> ppr br, - text "Bogus incomp:" <+> ppr br']) } - -lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () -lint_axiom_group (_ :| []) = return () -lint_axiom_group (ax :| axs) - = do { lintL (isOpenFamilyTyCon tc) - (text "Non-open-family with multiple axioms") - ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs - , ax2 <- all_axs ] - ; mapM_ (lint_axiom_pair tc) all_pairs } - where - all_axs = ax : axs - tc = coAxiomTyCon ax - -lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () -lint_axiom_pair tc (ax1, ax2) - | Just br1@(CoAxBranch { cab_tvs = tvs1 - , cab_lhs = lhs1 - , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 - , Just br2@(CoAxBranch { cab_tvs = tvs2 - , cab_lhs = lhs2 - , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 - = lintL (compatibleBranches br1 br2) $ - vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 - , text "are incompatible" ] - , text "tvs1 =" <+> pprTyVars tvs1 - , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) - , text "rhs1 =" <+> ppr rhs1 - , text "tvs2 =" <+> pprTyVars tvs2 - , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) - , text "rhs2 =" <+> ppr rhs2 ] - - | otherwise - = addErrL (text "Open type family axiom has more than one branch: either" <+> - ppr ax1 <+> text "or" <+> ppr ax2) - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: TCvSubst -- Current TyCo substitution - -- See Note [Linting type lets] - -- /Only/ substitutes for type variables; - -- but might clone CoVars - -- We also use le_subst to keep track of - -- in-scope TyVars and CoVars (but not Ids) - -- Range of the TCvSubst is LintedType/LintedCo - - , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids - -- Used to check that occurrences have an enclosing binder. - -- The Id is /pre-substitution/, used to check that - -- the occurrence has an identical type to the binder - -- The LintedType is used to return the type of the occurrence, - -- without having to lint it again. - - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of the InScopeSet in le_subst - -- See Note [Join points] - - , le_dynflags :: DynFlags -- DynamicFlags - , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the - -- alias-like binders, as found in - -- non-recursive lets. - } - -data LintFlags - = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] - , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] - , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] - , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] - , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] - , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] - } - --- See Note [Checking StaticPtrs] -data StaticPtrCheck - = AllowAnywhere - -- ^ Allow 'makeStatic' to occur anywhere. - | AllowAtTopLevel - -- ^ Allow 'makeStatic' calls at the top-level only. - | RejectEverywhere - -- ^ Reject any 'makeStatic' occurrence. - deriving Eq - -defaultLintFlags :: DynFlags -> LintFlags -defaultLintFlags dflags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags - , lf_report_unsat_syns = True - , lf_check_fixed_rep = True - } - -newtype LintM a = - LintM { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Warning and error messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - deriving (Functor) - -type WarnsAndErrs = (Bag SDoc, Bag SDoc) - -{- Note [Checking for global Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before CoreTidy, all locally-bound Ids must be LocalIds, even -top-level ones. See Note [Exported LocalIds] and #9857. - -Note [Checking StaticPtrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. - -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. - -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - -Note [Linting type synonym applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting a type-synonym, or type-family, application - S ty1 .. tyn -we behave as follows (#15057, #T15664): - -* If lf_report_unsat_syns = True, and S has arity < n, - complain about an unsaturated type synonym or type family - -* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. - - Reason: catch out of scope variables or other ill-kinded gubbins, - even if S discards that argument entirely. E.g. (#15012): - type FakeOut a = Int - type family TF a - type instance TF Int = FakeOut a - Here 'a' is out of scope; but if we expand FakeOut, we conceal - that out-of-scope error. - - Reason for switching off lf_report_unsat_syns: with - LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they - are saturated when the type is expanded. Example - type T f = f Int - type S a = a -> a - type Z = T S - In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. - -* If lf_report_unsat_syns is on, expand the synonym application and - lint the result. Reason: want to check that synonyms are saturated - when the type is expanded. - -Note [Linting linearity] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is one known optimisations that have not yet been updated -to work with Linear Lint: - -* Optimisations can create a letrec which uses a variable linearly, e.g. - letrec f True = f False - f False = x - in f True - uses 'x' linearly, but this is not seen by the linter. - Plan: make let-bound variables remember the usage environment. - See ticket #18694. - -We plan to fix this issue in the very near future. -For now, -dcore-lint enables only linting output of the desugarer, -and full Linear Lint has to be enabled separately with -dlinear-core-lint. -Ticket #19165 concerns enabling Linear Lint with -dcore-lint. - -Note [checkCanEtaExpand] -~~~~~~~~~~~~~~~~~~~~~~~~ -The checkCanEtaExpand function is responsible for enforcing invariant I3 -from Note [Representation polymorphism invariants] in GHC.Core: in any -partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to -eta expand `f` to match the declared arity of `f`. - -Wrinkle 1: eta-expansion and newtypes - - Most of the time, when we have a partial application `f e_1 .. e_n` - in which `f` is `hasNoBinding`, we eta-expand it up to its arity - as follows: - - \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity - - However, we might need to insert casts if some of the arguments - that `f` takes are under a newtype. - For example, suppose `f` `hasNoBinding`, has arity 1 and type - - f :: forall r (a :: TYPE r). Identity (a -> a) - - then we eta-expand the nullary application `f` to - - ( \ x -> f x ) |> co - - where - - co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) ) - - In this case we would have to perform a representation-polymorphism check on the instantiation - of `a`. - -Wrinkle 2: 'hasNoBinding' and laziness - - It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing - the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in - Note [Lazily checking Unfoldings] in GHC.IfaceToCore. --} - -instance Applicative LintM where - pure x = LintM $ \ _ errs -> (Just x, errs) - (<*>) = ap - -instance Monad LintM where - m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in - case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) - -instance MonadFail LintM where - fail err = failWithL (text err) - -instance HasDynFlags LintM where - getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) - -data LintLocInfo - = RhsOf Id -- The variable bound - | OccOf Id -- Occurrence of id - | LambdaBodyOf Id -- The lambda-binder - | RuleOf Id -- Rules attached to a binder - | UnfoldingOf Id -- Unfolding of a binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | CaseTy CoreExpr -- The type field of a case expression - -- with this scrutinee - | IdTy Id -- The type field of an Id binder - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InCo Coercion -- Inside a coercion - | InAxiom (CoAxiom Branched) -- Inside a CoAxiom - -initL :: DynFlags - -> LintFlags - -> [Var] -- ^ 'Id's that should be treated as being in scope - -> LintM a -- ^ Action to run - -> WarnsAndErrs -initL dflags flags vars m - = case unLintM m env (emptyBag, emptyBag) of - (Just _, errs) -> errs - (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs - | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ - "without reporting an error message") empty - where - (tcvs, ids) = partition isTyCoVar vars - env = LE { le_flags = flags - , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs)) - , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] - , le_joins = emptyVarSet - , le_loc = [] - , le_dynflags = dflags - , le_ue_aliases = emptyNameEnv } - -setReportUnsat :: Bool -> LintM a -> LintM a --- Switch off lf_report_unsat_syns -setReportUnsat ru thing_inside - = LintM $ \ env errs -> - let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } - in unLintM thing_inside env' errs - --- See Note [Checking for representation polymorphism] -noFixedRuntimeRepChecks :: LintM a -> LintM a -noFixedRuntimeRepChecks thing_inside - = LintM $ \env errs -> - let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } - in unLintM thing_inside env' errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) - -checkL :: Bool -> SDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - --- like checkL, but relevant to type checking -lintL :: Bool -> SDoc -> LintM () -lintL = checkL - -checkWarnL :: Bool -> SDoc -> LintM () -checkWarnL True _ = return () -checkWarnL False msg = addWarnL msg - -failWithL :: SDoc -> LintM a -failWithL msg = LintM $ \ env (warns,errs) -> - (Nothing, (warns, addMsg True env errs msg)) - -addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg True env errs msg)) - -addWarnL :: SDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - (Just (), (addMsg False env warns msg, errs)) - -addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc -addMsg is_error env msgs msg - = assertPpr (notNull loc_msgs) msg $ - msgs `snocBag` mk_msg msg - where - loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first - loc_msgs = map dumpLoc (le_loc env) - - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] - context | is_error = cxt_doc - | otherwise = whenPprDebug cxt_doc - -- Print voluminous info for Lint errors - -- but not for warnings - - msg_span = case [ span | (loc,_) <- loc_msgs - , let span = srcLocSpan loc - , isGoodSrcSpan span ] of - [] -> noSrcSpan - (s:_) -> s - !diag_opts = initDiagOpts (le_dynflags env) - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span - (msg $$ context) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m - = LintM $ \ env errs -> - unLintM m (env { le_loc = extra_loc : le_loc env }) errs - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - -addInScopeId :: Id -> LintedType -> LintM a -> LintM a -addInScopeId id linted_ty m - = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs -> - unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) - , le_joins = add_joins join_set }) errs - where - add_joins join_set - | isJoinId id = extendVarSet join_set id -- Overwrite with new arity - | otherwise = delVarSet join_set id -- Remove any existing binding - -getInScopeIds :: LintM (VarEnv (Id,LintedType)) -getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs)) - -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a -extendTvSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs - -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst subst' m - = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs - -markAllJoinsBad :: LintM a -> LintM a -markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs - -markAllJoinsBadIf :: Bool -> LintM a -> LintM a -markAllJoinsBadIf True m = markAllJoinsBad m -markAllJoinsBadIf False m = m - -getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) - -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getUEAliases :: LintM (NameEnv UsageEnv) -getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) - -lookupIdInScope :: Id -> LintM (Id, LintedType) -lookupIdInScope id_occ - = do { in_scope_ids <- getInScopeIds - ; case lookupVarEnv in_scope_ids id_occ of - Just (id_bndr, linted_ty) - -> do { checkL (not (bad_global id_bndr)) global_in_scope - ; return (id_bndr, linted_ty) } - Nothing -> do { checkL (not is_local) local_out_of_scope - ; return (id_occ, idType id_occ) } } - -- We don't bother to lint the type - -- of global (i.e. imported) Ids - where - is_local = mustHaveLocalBinding id_occ - local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ - global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") - 2 (pprBndr LetBind id_occ) - bad_global id_bnd = isGlobalId id_occ - && isLocalId id_bnd - && not (isWiredIn id_occ) - -- 'bad_global' checks for the case where an /occurrence/ is - -- a GlobalId, but there is an enclosing binding fora a LocalId. - -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, - -- but GHCi adds GlobalIds from the interactive context. These - -- are fine; hence the test (isLocalId id == isLocalId v) - -- NB: when compiling Control.Exception.Base, things like absentError - -- are defined locally, but appear in expressions as (global) - -- wired-in Ids after worker/wrapper - -- So we simply disable the test in this case - -lookupJoinId :: Id -> LintM (Maybe JoinArity) --- Look up an Id which should be a join point, valid here --- If so, return its arity, if not return Nothing -lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (isJoinId_maybe id') - Nothing -> return Nothing } - -addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a -addAliasUE id ue thing_inside = LintM $ \ env errs -> - let new_ue_aliases = - extendNameEnv (le_ue_aliases env) (getName id) ue - in - unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs - -varCallSiteUsage :: Id -> LintM UsageEnv -varCallSiteUsage id = - do m <- getUEAliases - return $ case lookupNameEnv m (getName id) of - Nothing -> unitUE id One - Just id_ue -> id_ue - -ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () --- check ty2 is subtype of ty1 (ie, has same structure but usage --- annotations need only be consistent, not equal) --- Assumes ty1,ty2 are have already had the substitution applied -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 (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg - -ensureSubMult :: Mult -> Mult -> SDoc -> LintM () -ensureSubMult actual_usage described_usage err_msg = do - flags <- getLintFlags - when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of - Submult -> return () - Unknown -> case isMultMul actual_usage' of - Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >> - ensureSubMult m2 described_usage' err_msg - Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) - - where actual_usage' = normalize actual_usage - described_usage' = normalize described_usage - - normalize :: Mult -> Mult - normalize m = case isMultMul m of - Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2) - Nothing -> m - -lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () -lintRole co r1 r2 - = lintL (r1 == r2) - (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> - text "got" <+> ppr r2 $$ - text "in" <+> ppr co) - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) - -dumpLoc (OccOf v) - = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) - -dumpLoc (RuleOf b) - = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) - -dumpLoc (UnfoldingOf b) - = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, text "In body of a letrec with no binders") - -dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) - -dumpLoc (AnExpr e) - = (noSrcLoc, text "In the expression:" <+> ppr e) - -dumpLoc (CaseAlt (Alt con args _)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CasePat (Alt con args _)) - = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CaseTy scrut) - = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") - 2 (ppr scrut)) - -dumpLoc (IdTy b) - = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) - -dumpLoc (ImportedUnfolding locn) - = (locn, text "In an imported unfolding") -dumpLoc TopLevelBindings - = (noSrcLoc, Outputable.empty) -dumpLoc (InType ty) - = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCo co) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) -dumpLoc (InAxiom ax) - = (getSrcLoc ax, hang (text "In the coercion axiom") - 2 (pprCoAxiom ax)) - -pp_binders :: [Var] -> SDoc -pp_binders bs = sep (punctuate comma (map pp_binder bs)) - -pp_binder :: Var -> SDoc -pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] - ------------------------------------------------------- --- Messages for case expressions - -mkDefaultArgsMsg :: [Var] -> SDoc -mkDefaultArgsMsg args - = hang (text "DEFAULT case with binders") - 4 (ppr args) - -mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc -mkCaseAltMsg e ty1 ty2 - = hang (text "Type of case alternatives not the same as the annotation on case:") - 4 (vcat [ text "Actual type:" <+> ppr ty1, - text "Annotation on case:" <+> ppr ty2, - text "Alt Rhs:" <+> ppr e ]) - -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc -mkScrutMsg var var_ty scrut_ty subst - = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, - text "Result binder type:" <+> ppr var_ty,--(idType var), - text "Scrutinee type:" <+> ppr scrut_ty, - hsep [text "Current TCv subst", ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) -mkNonIncreasingAltsMsg e - = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) - -nonExhaustiveAltsMsg :: CoreExpr -> SDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - -mkBadConMsg :: TyCon -> DataCon -> SDoc -mkBadConMsg tycon datacon - = vcat [ - text "In a case alternative, data constructor isn't in scrutinee type:", - text "Scrutinee type constructor:" <+> ppr tycon, - text "Data con:" <+> ppr datacon - ] - -mkBadPatMsg :: Type -> Type -> SDoc -mkBadPatMsg con_result_ty scrut_ty - = vcat [ - text "In a case alternative, pattern result type doesn't match scrutinee type:", - text "Pattern result type:" <+> ppr con_result_ty, - text "Scrutinee type:" <+> ppr scrut_ty - ] - -integerScrutinisedMsg :: SDoc -integerScrutinisedMsg - = text "In a LitAlt, the literal is lifted (probably Integer)" - -mkBadAltMsg :: Type -> CoreAlt -> SDoc -mkBadAltMsg scrut_ty alt - = vcat [ text "Data alternative when scrutinee is not a tycon application", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - -mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc -mkNewTyDataConAltMsg scrut_ty alt - = vcat [ text "Data alternative for newtype datacon", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - - ------------------------------------------------------- --- Other error messages - -mkAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkAppMsg expected_arg_ty actual_arg_ty arg - = vcat [text "Argument value doesn't match argument type:", - hang (text "Expected arg type:") 4 (ppr expected_arg_ty), - hang (text "Actual arg type:") 4 (ppr actual_arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [text "Non-function type in function position", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> SDoc -mkLetErr bndr rhs - = vcat [text "Bad `let' binding:", - hang (text "Variable:") - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (text "Rhs:") - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> SDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (text "Exp type:") - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -emptyRec :: CoreExpr -> SDoc -emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) - -mkRhsMsg :: Id -> SDoc -> Type -> SDoc -mkRhsMsg binder what ty - = vcat - [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty]] - -mkLetAppMsg :: CoreExpr -> SDoc -mkLetAppMsg e - = hang (text "This argument does not satisfy the let/app invariant:") - 2 (ppr e) - -badBndrTyMsg :: Id -> SDoc -> SDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - -mkNonTopExportedMsg :: Id -> SDoc -mkNonTopExportedMsg binder - = hsep [text "Non-top-level binder is marked as exported:", ppr binder] - -mkNonTopExternalNameMsg :: Id -> SDoc -mkNonTopExternalNameMsg binder - = hsep [text "Non-top-level binder has an external name:", ppr binder] - -mkTopNonLitStrMsg :: Id -> SDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - -mkKindErrMsg :: TyVar -> Type -> SDoc -mkKindErrMsg tyvar arg_ty - = vcat [text "Kinds don't match in type application:", - hang (text "Type variable:") - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc -mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) - -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc -mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) - -mk_cast_err :: String -- ^ What sort of casted thing this is - -- (\"expression\" or \"type\"). - -> String -- ^ What sort of coercion is being used - -- (\"type\" or \"kind\"). - -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> SDoc -mk_cast_err thing_str co_str pp_thing co from_ty thing_ty - = vcat [from_msg <+> text "of Cast differs from" <+> co_msg - <+> text "of" <+> enclosed_msg, - from_msg <> colon <+> ppr from_ty, - text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon - <+> ppr thing_ty, - text "Actual" <+> enclosed_msg <> colon <+> pp_thing, - text "Coercion used in cast:" <+> ppr co - ] - where - co_msg, from_msg, enclosed_msg :: SDoc - co_msg = text co_str - from_msg = text "From-" <> co_msg - enclosed_msg = text "enclosed" <+> text thing_str - -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co - = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co - -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co - = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") - 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) - -mkBadTyVarMsg :: Var -> SDoc -mkBadTyVarMsg tv - = text "Non-tyvar used in TyVarTy:" - <+> ppr tv <+> dcolon <+> ppr (varType tv) - -mkBadJoinBindMsg :: Var -> SDoc -mkBadJoinBindMsg var - = vcat [ text "Bad join point binding:" <+> ppr var - , text "Join points can be bound only by a non-top-level let" ] - -mkInvalidJoinPointMsg :: Var -> Type -> SDoc -mkInvalidJoinPointMsg var ty - = hang (text "Join point has invalid type:") - 2 (ppr var <+> dcolon <+> ppr ty) - -mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc -mkBadJoinArityMsg var ar n rhs - = vcat [ text "Join point has too few lambdas", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr (ar - n), - text "Rhs = " <+> ppr rhs - ] - -invalidJoinOcc :: Var -> SDoc -invalidJoinOcc var - = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var - , text "The binder is either not a join point, or not valid here" ] - -mkBadJumpMsg :: Var -> Int -> Int -> SDoc -mkBadJumpMsg var ar nargs - = vcat [ text "Join point invoked with wrong number of arguments", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of arguments:" <+> int nargs ] - -mkInconsistentRecMsg :: [Var] -> SDoc -mkInconsistentRecMsg bndrs - = vcat [ text "Recursive let binders mix values and join points", - text "Binders:" <+> hsep (map ppr_with_details bndrs) ] - where - ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) - -mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc -mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ - = vcat [ text "Mismatch in join point arity between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Arity at binding site:" <+> ppr join_arity_bndr - , text "Arity at occurrence: " <+> ppr join_arity_occ ] - -mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc -mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty - = vcat [ text "Mismatch in type between binder and occurrence" - , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty - , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty - , text " Before subst:" <+> ppr (idType var) ] - -mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc -mkBadJoinPointRuleMsg bndr join_arity rule - = vcat [ text "Join point has rule with wrong number of arguments" - , text "Var:" <+> ppr bndr - , text "Join arity:" <+> ppr join_arity - , text "Rule:" <+> ppr rule ] - -pprLeftOrRight :: LeftOrRight -> SDoc -pprLeftOrRight CLeft = text "left" -pprLeftOrRight CRight = text "right" - -dupVars :: [NonEmpty Var] -> SDoc -dupVars vars - = hang (text "Duplicate variables brought into scope") - 2 (ppr (map toList vars)) - -dupExtVars :: [NonEmpty Name] -> SDoc -dupExtVars vars - = hang (text "Duplicate top-level variables with the same qualified name") - 2 (ppr (map toList vars)) - -{- -************************************************************************ -* * -\subsection{Annotation Linting} -* * -************************************************************************ --} - --- | This checks whether a pass correctly looks through debug --- annotations (@SourceNote@). This works a bit different from other --- consistency checks: We check this by running the given task twice, --- noting all differences between the results. -lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do - -- Run the pass as we normally would - dflags <- getDynFlags - logger <- getLogger - when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass logger "Annotation linting - first run" - nguts <- pass guts - -- If appropriate re-run it without debug annotations to make sure - -- that they made no difference. - when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass logger "Annotation linting - second run" - nguts' <- withoutAnnots pass guts - -- Finally compare the resulting bindings - liftIO $ Err.showPass logger "Annotation linting - comparison" - let binds = flattenBinds $ mg_binds nguts - binds' = flattenBinds $ mg_binds nguts' - (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' - when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat - [ lint_banner "warning" pname - , text "Core changes with annotations:" - , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs - ] - -- Return actual new guts - return nguts - --- | Run the given pass without annotations. This means that we both --- set the debugLevel setting to 0 in the environment as well as all --- annotations from incoming modules. -withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -withoutAnnots pass guts = do - -- Remove debug flag from environment. - dflags <- getDynFlags - let removeFlag env = hscSetFlags (dflags { debugLevel = 0}) env - withoutFlag corem = - -- TODO: supply tag here as well ? - liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> - getUniqMask <*> getModule <*> - getVisibleOrphanMods <*> - getPrintUnqualified <*> getSrcSpanM <*> - pure corem - -- Nuke existing ticks in module. - -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes - -- them in absence of debugLevel > 0. - let nukeTicks = stripTicksE (not . tickishIsCode) - nukeAnnotsBind :: CoreBind -> CoreBind - nukeAnnotsBind bind = case bind of - Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs - NonRec b e -> NonRec b $ nukeTicks e - nukeAnnotsMod mg@ModGuts{mg_binds=binds} - = mg{mg_binds = map nukeAnnotsBind binds} - -- Perform pass with all changes applied - fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint ( + LintPassResultConfig (..), + LintFlags (..), + StaticPtrCheck (..), + LintConfig (..), + WarnsAndErrs, + + lintCoreBindings', lintUnfolding, + lintPassResult, lintExpr, + lintAnnots, lintAxioms, + + -- ** Debug output + EndPassConfig (..), + endPassIO, + displayLintResults, dumpPassResult + ) where + +import GHC.Prelude + +import GHC.Driver.Session + +import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) +import GHC.Unit.Module.ModGuts +import GHC.Platform + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import GHC.Core.DataCon +import GHC.Core.Ppr +import GHC.Core.Coercion +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 +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv( compatibleBranches ) +import GHC.Core.Unify +import GHC.Core.Coercion.Opt ( checkAxInstCo ) +import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) + +import GHC.Core.Opt.Monad + +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types ( multiplicityTy ) + +import GHC.Data.Bag +import GHC.Data.List.SetOps + +import GHC.Utils.Monad +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Error +import qualified GHC.Utils.Error as Err +import GHC.Utils.Logger + +import Control.Monad +import Data.Foldable ( for_, toList ) +import Data.List.NonEmpty ( NonEmpty(..), groupWith ) +import Data.List ( partition ) +import Data.Maybe +import GHC.Data.Pair +import GHC.Base (oneShot) +import GHC.Data.Unboxed + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Bool in + let x::a = True in +That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". +One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] +in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). + +* Hence when linting we need to remember that a=Int, else we + might reject a correct program. So we carry a type substitution (in + this example [a -> Bool]) and apply this substitution before + comparing types. In effect, in Lint, type equality is always + equality-modulo-le-subst. This is in the le_subst field of + LintEnv. But nota bene: + + (SI1) The le_subst substitution is applied to types and coercions only + + (SI2) The result of that substitution is used only to check for type + equality, to check well-typed-ness, /but is then discarded/. + The result of substitution does not outlive the CoreLint pass. + + (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. + +* The function + lintInTy :: Type -> LintM (Type, Kind) + returns a substituted type. + +* When we encounter a binder (like x::a) we must apply the substitution + to the type of the binding variable. lintBinders does this. + +* Clearly we need to clone tyvar binders as we go. + +* But take care (#17590)! We must also clone CoVar binders: + let a = TYPE (ty |> cv) + in \cv -> blah + blindly substituting for `a` might capture `cv`. + +* Alas, when cloning a coercion variable we might choose a unique + that happens to clash with an inner Id, thus + \cv_66 -> let wild_X7 = blah in blah + We decide to clone `cv_66` because it's already in scope. Fine, + choose a new unique. Aha, X7 looks good. So we check the lambda + body with le_subst of [cv_66 :-> cv_X7] + + This is all fine, even though we use the same unique as wild_X7. + As (SI2) says, we do /not/ return a new lambda + (\cv_X7 -> let wild_X7 = blah in ...) + We simply use the le_subst substitution in types/coercions only, when + checking for equality. + +* We still need to check that Id occurrences are bound by some + enclosing binding. We do /not/ use the InScopeSet for the le_subst + for this purpose -- it contains only TyCoVars. Instead we have a separate + le_ids for the in-scope Id binders. + +Sigh. We might want to explore getting rid of type-let! + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +Note [Avoiding compiler perf traps when constructing error messages.] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's quite common to put error messages into a where clause when it might +be triggered by multiple branches. E.g. + + checkThing x y z = + case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + where + errMsg = text "My error involving:" $$ ppr x <+> ppr y + +However ghc will compile this to: + + checkThink x y z = + let errMsg = text "My error involving:" $$ ppr x <+> ppr y + in case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + +Putting the allocation of errMsg into the common non-error path. +One way to work around this is to turn errMsg into a function: + + checkThink x y z = + case x of + X -> unless (correctX x) $ failWithL (errMsg x y) + Y -> unless (correctY y) $ failWithL (errMsg x y) + where + errMsg x y = text "My error involving:" $$ ppr x <+> ppr y + +This way `errMsg` is a static function and it being defined in the common +path does not result in allocation in the hot path. This can be surprisingly +impactful. Changing `lint_app` reduced allocations for one test program I was +looking at by ~4%. + + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ +-} + +-- | Configuration for boilerplate operations at the end of a +-- compilation pass producing Core. +data EndPassConfig = EndPassConfig + { ep_dumpCoreSizes :: !Bool + -- ^ Whether core bindings should be dumped with the size of what they + -- are binding (i.e. the size of the RHS of the binding). + + , ep_lintPassResult :: !(Maybe LintPassResultConfig) + -- ^ Whether we should lint the result of this pass. + + , ep_namePprCtx :: !NamePprCtx + + , ep_dumpFlag :: !(Maybe DumpFlag) + + , ep_prettyPass :: !SDoc + + , ep_passDetails :: !SDoc + } + +endPassIO :: Logger + -> EndPassConfig + -> CoreProgram -> [CoreRule] + -> IO () +-- Used by the IO-is CorePrep too +endPassIO logger cfg binds rules + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag + (renderWithContext defaultSDocContext (ep_prettyPass cfg)) + (ep_passDetails cfg) binds rules + ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> + lintPassResult logger lp_cfg binds + } + where + mb_flag = case ep_dumpFlag cfg of + Just flag | logHasDumpFlag logger flag -> Just flag + | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag + _ -> Nothing + +dumpPassResult :: Logger + -> Bool -- dump core sizes? + -> NamePprCtx + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> String -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg logger 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , if dump_core_sizes + then pprCoreBindingsWithSize binds + else pprCoreBindings binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +data LintPassResultConfig = LintPassResultConfig + { lpr_diagOpts :: !DiagOpts + , lpr_platform :: !Platform + , lpr_makeLintFlags :: !LintFlags + , lpr_showLintWarnings :: !Bool + , lpr_passPpr :: !SDoc + , lpr_localsInScope :: ![Var] + } + +lintPassResult :: Logger -> LintPassResultConfig + -> CoreProgram -> IO () +lintPassResult logger cfg binds + = do { let warns_and_errs = lintCoreBindings' + (LintConfig + { l_diagOpts = lpr_diagOpts cfg + , l_platform = lpr_platform cfg + , l_flags = lpr_makeLintFlags cfg + , l_vars = lpr_localsInScope cfg + }) + binds + ; Err.showPass logger $ + "Core Linted result of " ++ + renderWithContext defaultSDocContext (lpr_passPpr cfg) + ; displayLintResults logger + (lpr_showLintWarnings cfg) (lpr_passPpr cfg) + (pprCoreBindings binds) warns_and_errs + } + +displayLintResults :: Logger + -> Bool -- ^ If 'True', display linter warnings. + -- If 'False', ignore linter warnings. + -> SDoc -- ^ The source of the linted program + -> SDoc -- ^ The linted program, pretty-printed + -> WarnsAndErrs + -> IO () +displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) + | not (isEmptyBag errs) + = do { logMsg logger Err.MCDump noSrcSpan + $ withPprStyle defaultDumpStyle + (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs + , text "*** Offending Program ***" + , pp_pgm + , text "*** End of Offense ***" ]) + ; Err.ghcExit logger 1 } + + | not (isEmptyBag warns) + , log_enable_debug (logFlags logger) + , display_warnings + -- If the Core linter encounters an error, output to stderr instead of + -- stdout (#13342) + = logMsg logger Err.MCInfo noSrcSpan + $ withPprStyle defaultDumpStyle + (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings' cfg binds + = initL cfg $ + addLoc TopLevelBindings $ + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; lintRecBindings TopLevel all_pairs $ \_ -> + return () } + where + all_pairs = flattenBinds binds + -- Put all the top-level binders in scope at the start + -- This is because rewrite rules can bring something + -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" + binders = map fst all_pairs + + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- ^ True <=> is a compulsory unfolding + -> LintConfig + -> SrcLoc + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintUnfolding is_compulsory cfg locn expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg $ + if is_compulsory + -- See Note [Checking for representation polymorphism] + then noFixedRuntimeRepChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: LintConfig + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintExpr cfg expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +-- Returns a UsageEnv because this function is called in lintCoreExpr for +-- Let + +lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] + -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv]) +lintRecBindings top_lvl pairs thing_inside + = lintIdBndrs top_lvl bndrs $ \ bndrs' -> + do { ues <- zipWithM lint_pair bndrs' rhss + ; a <- thing_inside bndrs' + ; return (a, ues) } + where + (bndrs, rhss) = unzip pairs + lint_pair bndr' rhs + = addLoc (RhsOf bndr') $ + do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + ; return ue } + +lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv) +lintLetBody bndrs body + = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + ; mapM_ (lintJoinBndrType body_ty) bndrs + ; return (body_ty, body_ue) } + +lintLetBind :: TopLevelFlag -> RecFlag -> LintedId + -> CoreExpr -> LintedType -> LintM () +-- Binder's type, and the RHS, have already been linted +-- This function checks other invariants +lintLetBind top_lvl rec_flag binder rhs rhs_ty + = do { let binder_ty = idType binder + ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check the let-can-float invariant + -- See Note [Core let-can-float invariant] in GHC.Core + ; checkL ( isJoinId binder + || mightBeLiftedType binder_ty + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal. + -- See Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case isJoinId_maybe binder of + Nothing -> return () + Just arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal + + -- Check that the binder's arity is within the bounds imposed by the type + -- and the strictness signature. See Note [Arity invariants for bindings] + -- and Note [Trimming arity] + + ; checkL (typeArity (idType binder) >= idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (typeArity (idType binder)) <> colon <+> + ppr binder) + + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal + ; case splitDmdSig (idDmdSig binder) of + (demands, result_info) | isDeadEndDiv result_info -> + checkL (demands `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds arity imposed by the strictness signature" <+> + ppr (idDmdSig binder) <> colon <+> + ppr binder) + + _ -> return () + + ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) + ; return () } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv) +-- NB: the Id can be Linted or not -- it's only used for +-- its OccInfo and join-pointer-hood +lintRhs bndr rhs + | Just arity <- isJoinId_maybe bndr + = lintJoinLams arity (Just bndr) rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lintJoinLams arity Nothing rhs + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty_ue <- lintCoreExpr fun + lintCoreArgs fun_ty_ue [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +-- | Lint the RHS of a join point with expected join arity of @n@ (see Note +-- [Join points] in "GHC.Core"). +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv) +lintJoinLams join_arity enforce rhs + = go join_arity rhs + where + go 0 expr = lintCoreExpr expr + go n (Lam var body) = lintLambda var $ go (n-1) body + go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr expr + -- Body of lambda is not a tail position + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- fst <$> (if isCompulsoryUnfolding uf + then noFixedRuntimeRepChecks $ lintRhs bndr rhs + -- ^^^^^^^^^^^^^^^^^^^^^^^ + -- See Note [Checking for representation polymorphism] + else lintRhs bndr rhs) + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. Here is an example: + instance Eq T where + t1 == t2 = blah + t1 /= t2 = not (t1 == t2) + {-# INLINE (/=) #-} + +This will generate something like + -- From the class decl for Eq + data Eq a = EqDict (a->a->Bool) (a->a->Bool) + eq_sel :: Eq a -> (a->a->Bool) + eq_sel (EqDict eq _) = eq + + -- From the instance Eq T + $ceq :: T -> T -> Bool + $ceq = blah + + Rec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not (eq_sel $dfEqT x y) } + +Notice that + +* `$dfEqT` and `$cnotEq` are mutually recursive. + +* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and + we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun + selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop + breaker. + +So we make `$cnoteq` into the loop breaker. That means it can't +inline, despite the INLINE pragma. That's what gives rise to the +warning, which is perfectly appropriate for, say + Rec { {-# INLINE f #-} f = \x -> ...f.... } +We can't inline a recursive function -- it's a loop breaker. + +But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get + Rec { + $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +and now the dependencies of the Rec have gone, and we can split it up to give + NonRec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq } + + NonRec { $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +Now $cnoteq is not a loop breaker any more, so the INLINE pragma can +take effect -- the warning turned out to be temporary. + +To stop excessive warnings, this warning for INLINE loop breakers is +switched off when linting the result of the desugarer. See +lf_check_inline_loop_breakers in GHC.Core.Lint. + + +Note [Checking for representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad representation polymorphism. See +Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be representation-polymorphic; +indeed representation-polymorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, representation-polymorphic, binding). + +It is vitally important that we do representation polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +Note [Linting of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~ +runRW# has some very special behavior (see Note [runRW magic] in +GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing +join points in its argument. For example, this is fine: + + join j x = ... + in runRW# (\s. case v of + A -> j 3 + B -> j 4) + +Usually those calls to the join point 'j' would not be valid tail calls, +because they occur in a function argument. But in the case of runRW# +they are fine, because runRW# (\s.e) behaves operationally just like e. +(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) + +In the case that the continuation is /not/ a lambda we simply disable this +special behaviour. For example, this is /not/ fine: + + join j = ... + in runRW# @r @ty (jump j) + + + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +-- Linted things: substitution applied, and type is linted +type LintedType = Type +type LintedKind = Kind +type LintedCoercion = Coercion +type LintedTyCoVar = TyCoVar +type LintedId = Id + +-- | Lint an expression cast through the given coercion, returning the type +-- resulting from the cast. +lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType +lintCastExpr expr expr_ty co + = do { co' <- lintCoercion co + ; let (Pair from_ty to_ty, role) = coercionKindRole co' + ; checkValueType to_ty $ + text "target of cast" <+> quotes (ppr co') + ; lintRole co' Representational role + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv) +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoreExpr (Var var) + = do + var_pair@(var_ty, _) <- lintIdOcc var 0 + checkCanEtaExpand (Var var) [] var_ty + return var_pair + +lintCoreExpr (Lit lit) + = return (literalType lit, zeroUE) + +lintCoreExpr (Cast expr co) + = do (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) + -- markAllJoinsBad: see Note [Join points and casts] + to_ty <- lintCastExpr expr expr_ty co + return (to_ty, ue) + +lintCoreExpr (Tick tickish expr) + = do case tickish of + Breakpoint _ _ ids -> forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + _ -> return () + markAllJoinsBadIf block_joins $ lintCoreExpr expr + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- lintType ty + ; lintTyBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendTvSubstL tv ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { -- First Lint the RHS, before bringing the binder into scope + (rhs_ty, let_ue) <- lintRhs bndr rhs + + -- See Note [Multiplicity of let binders] in Var + -- Now lint the binder + ; lintBinder LetBind bndr $ \bndr' -> + do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty + ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; let (_, dups) = removeDups compare bndrs + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + -- See Note [Multiplicity of let binders] in Var + ; ((body_type, body_ue), ues) <- + lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody bndrs' body + ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1 addUE ues)) } + where + bndrs = map fst pairs + +lintCoreExpr e@(App _ _) + | Var fun <- fun + , fun `hasKey` runRWKey + -- N.B. we may have an over-saturated application of the form: + -- runRW (\s -> \x -> ...) y + , ty_arg1 : ty_arg2 : arg3 : rest <- args + = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 + ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 + -- See Note [Linting of runRW#] + ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) + lintRunRWCont expr@(Lam _ _) = + lintJoinLams 1 (Just fun) expr + lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other + -- TODO: Look through ticks? + ; (arg3_ty, ue3) <- lintRunRWCont arg3 + ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3 + ; lintCoreArgs app_ty rest } + + | otherwise + = do { fun_pair <- lintCoreFun fun (length args) + ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args + ; checkCanEtaExpand fun args app_ty + ; return app_pair} + where + skipTick t = case collectFunSimple e of + (Var v) -> etaExpansionTick v t + _ -> tickishFloatable t + (fun, args, _source_ticks) = collectArgsTicks skipTick e + -- We must look through source ticks to avoid #21152, for example: + -- + -- reallyUnsafePtrEquality + -- = \ @a -> + -- (src reallyUnsafePtrEquality#) + -- @Lifted @a @Lifted @a + -- + -- To do this, we use `collectArgsTicks tickishFloatable` to match + -- the eta expansion behaviour, as per Note [Eta expansion and source notes] + -- in GHC.Core.Opt.Arity. + -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. + -- See Note [Ticks and mandatory eta expansion] + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + = do { co' <- addLoc (InCo co) $ + lintCoercion co + ; return (coercionType co', zeroUE) } + +---------------------- +lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed + -> LintM (LintedType, UsageEnv) -- returns type of the *variable* +lintIdOcc var nargs + = addLoc (OccOf var) $ + do { checkL (isNonCoVarId var) + (text "Non term variable" <+> ppr var) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Check that the type of the occurrence is the same + -- as the type of the binding site. The inScopeIds are + -- /un-substituted/, so this checks that the occurrence type + -- is identical to the binder type. + -- This makes things much easier for things like: + -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... + -- The "::Maybe a" on the occurrence is referring to the /outer/ a. + -- If we compared /substituted/ types we'd risk comparing + -- (Maybe a) from the binding site with bogus (Maybe a1) from + -- the occurrence site. Comparing un-substituted types finesses + -- this altogether + ; (bndr, linted_bndr_ty) <- lookupIdInScope var + ; let occ_ty = idType var + bndr_ty = idType bndr + ; ensureEqTys occ_ty bndr_ty $ + mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName var /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc var + ; checkJoinOcc var nargs + + ; usage <- varCallSiteUsage var + + ; return (linted_bndr_ty, usage) } + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM (LintedType, UsageEnv) -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintIdOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; + -- See Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { (body_ty, ue) <- lintBody + ; ue' <- checkLinearity ue var' + ; return (mkLamType var' body_ty, ue') } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +lintJoinBndrType :: LintedType -- Type of the body + -> LintedId -- Possibly a join Id + -> LintM () +-- Checks that the return type of a join Id matches the body +-- E.g. join j x = rhs in body +-- The type of 'rhs' must be the same as the type of 'body' +lintJoinBndrType body_ty bndr + | Just arity <- isJoinId_maybe bndr + , let bndr_ty = idType bndr + , (bndrs, res) <- splitPiTys bndr_ty + = checkL (length bndrs >= arity + && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + | otherwise + = return () + +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | Just join_arity_occ <- isJoinId_maybe var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + Nothing -> -- Binder is not a join point + do { join_set <- getValidJoins + ; addErrL (text "join set " <+> ppr join_set $$ + invalidJoinOcc var) } ; + + Just join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +-- | This function checks that we are able to perform eta expansion for +-- functions with no binding, in order to satisfy invariant I3 +-- from Note [Representation polymorphism invariants] in GHC.Core. +checkCanEtaExpand :: CoreExpr -- ^ the function (head of the application) we are checking + -> [CoreArg] -- ^ the arguments to the application + -> LintedType -- ^ the instantiated type of the overall application + -> LintM () +checkCanEtaExpand (Var fun_id) args app_ty + = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags + ; when (do_rep_poly_checks && hasNoBinding fun_id) $ + checkL (null bad_arg_tys) err_msg } + where + arity :: Arity + arity = idArity fun_id + + nb_val_args :: Int + nb_val_args = count isValArg args + + -- Check the remaining argument types, past the + -- given arguments and up to the arity of the 'Id'. + -- Returns the types that couldn't be determined to have + -- a fixed RuntimeRep. + check_args :: [Type] -> [Type] + check_args = go (nb_val_args + 1) + where + go :: Int -- index of the argument (starting from 1) + -> [Type] -- arguments + -> [Type] -- value argument types that could not be + -- determined to have a fixed runtime representation + go i _ + | i > arity + = [] + go _ [] + -- The Arity of an Id should never exceed the number of value arguments + -- that can be read off from the Id's type. + -- See Note [Arity and function types] in GHC.Types.Id.Info. + = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type" + $ vcat + [ text "fun_id =" <+> ppr fun_id + , text "arity =" <+> ppr arity + , text "app_ty =" <+> ppr app_ty + , text "args = " <+> ppr args + , text "nb_val_args =" <+> ppr nb_val_args ] + go i (ty : bndrs) + | typeHasFixedRuntimeRep ty + = go (i+1) bndrs + | otherwise + = ty : go (i+1) bndrs + + bad_arg_tys :: [Type] + bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty + -- We use 'getRuntimeArgTys' to find all the argument types, + -- including those hidden under newtypes. For example, + -- if `FunNT a b` is a newtype around `a -> b`, then + -- when checking + -- + -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c + -- + -- we should check that the instantiations of BOTH `a` AND `b` + -- have a fixed runtime representation. + + err_msg :: SDoc + err_msg + = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id) + , text "The following type" <> plural bad_arg_tys + <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:" + , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ] + + ppr_ty_ki :: Type -> SDoc + ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty) +checkCanEtaExpand _ _ _ + = return () + +-- Check that the usage of var is consistent with var itself, and pop the var +-- from the usage environment (this is important because of shadowing). +checkLinearity :: UsageEnv -> Var -> LintM UsageEnv +checkLinearity body_ue lam_var = + case varMultMaybe lam_var of + Just mult -> do ensureSubUsage lhs mult (err_msg mult) + return $ deleteUE body_ue lam_var + Nothing -> return body_ue -- A type variable + where + lhs = lookupUE body_ue lam_var + err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var + $$ ppr lhs <+> text "⊈" <+> ppr mult + +{- Note [Join points and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that this should be OK: + join j x = rhs + in (case e of + A -> alt1 + B x -> (jump j x) |> co) + +You might think that, since the cast is ultimately erased, the jump to +`j` should still be OK as a join point. But no! See #21716. Suppose + + newtype Age = MkAge Int -- axAge :: Age ~ Int + f :: Int -> ... -- f strict in it's first argument + +and consider the expression + + f (join j :: Bool -> Age + j x = (rhs1 :: Age) + in case v of + Just x -> (j x |> axAge :: Int) + Nothing -> rhs2) + +Then, if the Simplifier pushes the strict call into the join points +and alternatives we'll get + + join j' x = f (rhs1 :: Age) + in case v of + Just x -> j' x |> axAge + Nothing -> f rhs2 + +Utterly bogus. `f` expects an `Int` and we are giving it an `Age`. +No no no. Casts destroy the tail-call property. Henc markAllJoinsBad +in the (Cast expr co) case of lintCoreExpr. + +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsDeadEnd is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + +-- Takes the functions type and arguments as argument. +-- Returns the *result* of applying the function to arguments. +-- e.g. f :: Int -> Bool -> Int would return `Int` as result type. +lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv) +lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args + +lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv) +lintCoreArg (fun_ty, ue) (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; arg_ty' <- lintType arg_ty + ; res <- lintTyApp fun_ty arg_ty' + ; return (res, ue) } + +lintCoreArg (fun_ty, fun_ue) arg + = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Representation polymorphism invariants] in GHC.Core + ; flags <- getLintFlags + + ; when (lf_check_fixed_rep flags) $ + -- Only check that 'arg_ty' has a fixed RuntimeRep + -- if 'lf_check_fixed_rep' is on. + do { checkL (typeHasFixedRuntimeRep arg_ty) + (text "Argument does not have a fixed runtime representation" + <+> ppr arg <+> dcolon + <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) } + + ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } + +----------------- +lintAltBinders :: UsageEnv + -> Var -- Case binder + -> LintedType -- Scrutinee type + -> LintedType -- Constructor type + -> [(Mult, OutVar)] -- Binders + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] + = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + ; return rhs_ue } +lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } + | otherwise + = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE + -- We can pass zeroUE to lintValApp because we ignore its usage + -- calculation and compute it in the call for checkCaseLinearity below. + ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr + ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + +-- | Implements the case rules for linearity +checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv +checkCaseLinearity ue case_bndr var_w bndr = do + ensureSubUsage lhs rhs err_msg + lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr) + return $ deleteUE ue bndr + where + lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) + rhs = case_bndr_w `mkMultMul` var_w + err_msg = (text "Linearity failure in variable:" <+> ppr bndr + $$ ppr lhs <+> text "⊈" <+> ppr rhs + $$ text "Computed by:" + <+> text "LHS:" <+> lhs_formula + <+> text "RHS:" <+> rhs_formula) + lhs_formula = ppr bndr_usage <+> text "+" + <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) + rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w + case_bndr_w = varMult case_bndr + case_bndr_usage = lookupUE ue case_bndr + bndr_usage = lookupUE ue bndr + + + +----------------- +lintTyApp :: LintedType -> LintedType -> LintM LintedType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTyCoVar_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- + +-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ +-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the +-- 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 + = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) + ; let app_ue = addUE fun_ue (scaleUE w arg_ue) + ; return (res_ty', app_ue) } + | otherwise + = failWithL err2 + where + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> LintedType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = unless (arg_kind `eqType` tyvar_kind) $ + addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) + where + tyvar_kind = tyVarKind tyvar + arg_kind = typeKind arg_ty + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv) +lintCaseExpr scrut var alt_ty alts = + do { let e = Case scrut var alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + ; let scrut_mult = varMult var + + ; alt_ty <- addLoc (CaseTy scrut) $ + lintValueType alt_ty + ; var_ty <- addLoc (IdTy var) $ + lintValueType (idType var) + + -- We used to try to check whether a case expression with no + -- alternatives was legitimate, but this didn't work. + -- See Note [No alternatives lint check] for details. + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + ; let isLitPat (Alt (LitAlt _) _ _) = True + isLitPat _ = False + ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts) + (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." + $$ text "scrut" <+> ppr scrut) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsDeadEnd scrut) + -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate + + ; subst <- getSubst + ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + -- See GHC.Core Note [Case expression invariants] item (7) + + ; lintBinder CaseBind var $ \_ -> + do { -- Check the alternatives + ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts + ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues + ; checkCaseAlts e scrut_ty alts + ; return (alt_ty, case_ue) } } + +checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (Alt DEFAULT _ _) = False + non_deflt _ = True + + is_infinite_ty = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv +lintAltExpr expr ann_ty + = do { (actual_ty, ue) <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) + ; return ue } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: Var -- Case binder + -> LintedType -- Type of scrutinee + -> Mult -- Multiplicity of scrutinee + -> LintedType -- Type of the alternative + -> CoreAlt + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; lintAltExpr rhs alt_ty } + +lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; lintAltExpr rhs alt_ty } + where + lit_ty = literalType lit + +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) + | isNewTyCon (dataConTyCon con) + = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + -- We've already check + lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; binderMult (Named _) = ManyTy + ; binderMult (Anon st _) = scaledMult st + -- See Note [Validating multiplicities in a case] + ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { + rhs_ue <- lintAltExpr rhs alt_ty + ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args')) + ; return $ deleteUE rhs_ue' case_bndr + } + } + + | otherwise -- Scrut-ty is wrong shape + = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) + +{- +Note [Validating multiplicities in a case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'MkT :: a %m -> T m a'. +If we are validating 'case (x :: T Many a) of MkT y -> ...', +we have to substitute m := Many in the type of MkT - in particular, +y can be used Many times and that expression would still be linear in x. +We do this by looking at con_payload_ty, which is the type of the datacon +applied to the surrounding arguments. +Testcase: linear/should_compile/MultConstructor + +Data constructors containing existential tyvars will then have +Named binders, which are always multiplicity Many. +Testcase: indexed-types/should_compile/GADT1 +-} + +lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () +lintLinearBinder doc actual_usage described_usage + = ensureSubMult actual_usage described_usage err_msg + where + err_msg = (text "Multiplicity of variable does not agree with its context" + $$ doc + $$ ppr actual_usage + $$ text "Annotation:" <+> ppr described_usage) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a +lintBinder site var linterF + | isTyCoVar var = lintTyCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyBndr = lintTyCoBndr -- We could specialise it, I guess + +lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyCoBndr tcv thing_inside + = do { subst <- getSubst + ; tcv_type' <- lintType (varType tcv) + ; let tcv' = uniqAway (getSubstInScope subst) $ + setVarType tcv tcv_type' + subst' = extendTCvSubstWithClone subst tcv 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 +lintIdBndrs top_lvl ids thing_inside + = go ids thing_inside + where + go :: [Id] -> ([Id] -> LintM a) -> LintM a + go [] thing_inside = thing_inside [] + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> + go ids $ \ids' -> + thing_inside (id' : ids') + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id thing_inside + = assertPpr (isId id) (ppr id) $ + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + -- See Note [Representation polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_fixed_rep flags) + || typeHasFixedRuntimeRep id_ty) $ + text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> + parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType id_ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + + -- Check that the lambda binder has no value or OtherCon unfolding. + -- See #21496 + ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) + (text "Lambda binder with value or OtherCon unfolding.") + + ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty) + + ; addInScopeId id linted_ty $ + thing_inside (setIdType id linted_ty) } + where + id_ty = idType id + + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +lintValueType :: Type -> LintM LintedType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintValueType ty + = addLoc (InType ty) $ + do { ty' <- lintType ty + ; let sk = typeKind ty' + ; lintL (isTYPEorCONSTRAINT sk) $ + hang (text "Ill-kinded type:" <+> ppr ty) + 2 (text "has kind:" <+> ppr sk) + ; return ty' } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintType :: Type -> LintM LintedType + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + | not (isTyVar tv) + = failWithL (mkBadTyVarMsg tv) + + | otherwise + = do { subst <- getSubst + ; case lookupTyVar subst tv of + Just linted_ty -> return linted_ty + + -- In GHCi we may lint an expression with a free + -- type variable. Then it won't be in the + -- substitution, but it should be in scope + Nothing | tv `isInScope` subst + -> return (TyVarTy tv) + | otherwise + -> failWithL $ + hang (text "The type variable" <+> pprBndr LetBind tv) + 2 (text "is out of scope") + } + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { t1' <- lintType t1 + ; t2' <- lintType t2 + ; lint_ty_app ty (typeKind t1') [t2'] + ; return (AppTy t1' t2') } + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | 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] + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy af tw t1 t2) + = do { t1' <- lintType t1 + ; 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) + | not (isTyCoVar tcv) + = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty) + | otherwise + = lintTyCoBndr tcv $ \tcv' -> + do { body_ty' <- lintType body_ty + ; lintForAllBody tcv' body_ty' + + ; when (isCoVar tcv) $ + lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $ + text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) + -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo] + + ; return (ForAllTy (Bndr tcv' vis) body_ty') } + +lintType ty@(LitTy l) + = do { lintTyLit l; return ty } + +lintType (CastTy ty co) + = do { ty' <- lintType ty + ; co' <- lintStarCoercion co + ; let tyk = typeKind ty' + cok = coercionLKind co' + ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok) + ; return (CastTy ty' co') } + +lintType (CoercionTy co) + = do { co' <- lintCoercion co + ; return (CoercionTy co') } + +----------------- +lintForAllBody :: LintedTyCoVar -> LintedType -> LintM () +-- Do the checks for the body of a forall-type +lintForAllBody tcv body_ty + = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty) + + -- For type variables, check for skolem escape + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + -- The kind of (forall cv. th) is liftedTypeKind, so no + -- need to check for skolem-escape in the CoVar case + ; let body_kind = typeKind body_ty + ; when (isTyVar tcv) $ + case occCheckExpand [tcv] body_kind of + Just {} -> return () + Nothing -> failWithL $ + hang (text "Variable escape in forall:") + 2 (vcat [ text "tyvar:" <+> ppr tcv + , text "type:" <+> ppr body_ty + , text "kind:" <+> ppr body_kind ]) + } + +----------------- +lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. GHC.Tc.Validity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + tys' <- setReportUnsat False (mapM lintType tys) + + ; when report_unsat $ + do { _ <- lintType expanded_ty + ; return () } + + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + + -- Otherwise this must be a type family + | otherwise + = do { tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +----------------- +-- Confirms that a type is really TYPE r or Constraint +checkValueType :: LintedType -> SDoc -> LintM () +checkValueType ty doc + = lintL (isTYPEorCONSTRAINT kind) + (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ + text "when checking" <+> doc) + where + kind = typeKind ty + +----------------- +lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- 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 (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 + 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 () +lint_ty_app msg_ty k tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = lint_app (\msg_ty -> text "type" <+> quotes (ppr msg_ty)) msg_ty k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () +lint_co_app msg_ty k tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = lint_app (\msg_ty -> text "coercion" <+> quotes (ppr msg_ty)) msg_ty k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () +lintTyLit (CharTyLit _) = return () + +lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM () +-- (lint_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +-- +-- Being strict in the kind here avoids quite a few pointless thunks +-- reducing allocations by ~5% +lint_app mk_msg msg_type !kfn arg_tys + = do { !in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst + -- Forcing the in scope set eagerly here reduces allocations by up to 4%. + ; go_app in_scope kfn arg_tys + } + where + + -- We use explicit recursion instead of a fold here to avoid go_app becoming + -- an allocated function closure. This reduced allocations by up to 7% for some + -- modules. + go_app :: InScopeSet -> LintedKind -> [Type] -> LintM () + go_app !in_scope !kfn ta + | Just kfn' <- coreView kfn + = go_app in_scope kfn' ta + + go_app _in_scope _kind [] = return () + + go_app in_scope fun_kind@(FunTy _ _ kfa kfb) (ta:tas) + = do { let ka = typeKind ta + ; unless (ka `eqType` kfa) $ + addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) + ; go_app in_scope kfb tas } + + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) (ta:tas) + = do { let kv_kind = varType kv + ka = typeKind ta + ; unless (ka `eqType` kv_kind) $ + addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ + ppr ta <+> dcolon <+> ppr ka))) + ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn + ; go_app in_scope kind' tas } + + go_app _ kfn ta + = failWithL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) + +-- This is a top level definition to ensure we pass all variables of the error message +-- explicitly and don't capture them as free variables. Otherwise this binder might +-- become a thunk that get's allocated in the hot code path. +-- See Note [Avoiding compiler perf traps when constructing error messages.] +lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc +lint_app_fail_msg kfn arg_tys mk_msg msg_type extra = vcat [ hang (text "Kind application error in") 2 (mk_msg msg_type) + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg types =" <+> ppr arg_tys) + , extra ] +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + ; (rhs_ty, _) <- case isJoinId_maybe fun of + Just join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in #10602, +SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in #10602, +it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +{- Note [Asymptotic efficiency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting coercions (and types actually) we return a linted +(substituted) coercion. Then we often have to take the coercionKind of +that returned coercion. If we get long chains, that can be asymptotically +inefficient, notably in +* TransCo +* InstCo +* SelCo (cf #9233) +* LRCo + +But the code is simple. And this is only Lint. Let's wait to see if +the bad perf bites us in practice. + +A solution would be to return the kind and role of the coercion, +as well as the linted coercion. Or perhaps even *only* the kind and role, +which is what used to happen. But that proved tricky and error prone +(#17923), so now we return the coercion. +-} + + +-- lints a coercion, confirming that its lh kind and its rh kind are both * +-- also ensures that the role is Nominal +lintStarCoercion :: InCoercion -> LintM LintedCoercion +lintStarCoercion g + = do { g' <- lintCoercion g + ; let Pair t1 t2 = coercionKind g' + ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) + ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal (coercionRole g) + ; return g' } + +lintCoercion :: InCoercion -> LintM LintedCoercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + + | otherwise + = do { subst <- getSubst + ; case lookupCoVar subst cv of + Just linted_co -> return linted_co ; + Nothing + | cv `isInScope` subst + -> return (CoVarCo cv) + | otherwise + -> + -- lintCoBndr always extends the substitution + failWithL $ + hang (text "The coercion variable" <+> pprBndr LetBind cv) + 2 (text "is out of scope") + } + + +lintCoercion (Refl ty) + = do { ty' <- lintType ty + ; return (Refl ty') } + +lintCoercion (GRefl r ty MRefl) + = do { ty' <- lintType ty + ; return (GRefl r ty' MRefl) } + +lintCoercion (GRefl r ty (MCo co)) + = do { ty' <- lintType ty + ; co' <- lintCoercion co + ; let tk = typeKind ty' + tl = coercionLKind co' + ; ensureEqTys tk tl $ + hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty', ppr tk, ppr tl]) + ; lintRole co' Nominal (coercionRole co') + ; return (GRefl r ty' (MCo co')) } + +lintCoercion co@(TyConAppCo r tc cos) + | 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 + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; cos' <- mapM lintCoercion cos + ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos') + ; lint_co_app co (tyConKind tc) (map pFst co_kinds) + ; lint_co_app co (tyConKind tc) (map pSnd co_kinds) + ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles + ; return (TyConAppCo r tc cos') } + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let (Pair lk1 rk1, r1) = coercionKindRole co1' + (Pair lk2 rk2, r2) = coercionKindRole co2' + ; lint_co_app co (typeKind lk1) [lk2] + ; lint_co_app co (typeKind rk1) [rk2] + + ; if r1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 + + ; return (AppCo co1' co2') } + +---------- +lintCoercion co@(ForAllCo tcv kind_co body_co) + | not (isTyCoVar tcv) + = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) + | otherwise + = do { kind_co' <- lintStarCoercion kind_co + ; lintTyCoBndr tcv $ \tcv' -> + do { body_co' <- lintCoercion body_co + ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ + text "Kind mis-match in ForallCo" <+> ppr co + + -- Assuming kind_co :: k1 ~ k2 + -- Need to check that + -- (forall (tcv:k1). lty) and + -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) + -- are both well formed. Easiest way is to call lintForAllBody + -- for each; there is actually no need to do the funky substitution + ; let Pair lty rty = coercionKind body_co' + ; lintForAllBody tcv' lty + ; lintForAllBody tcv' rty + + ; when (isCoVar tcv) $ + lintL (almostDevoidCoVarOfCo tcv body_co) $ + text "Covar can only appear in Refl and GRefl: " <+> ppr co + -- See "last wrinkle" in GHC.Core.Coercion + -- Note [Unused coercion variable in ForAllCo] + -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + + ; return (ForAllCo tcv' kind_co' body_co') } } + +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 + ; 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 (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 (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) + = do { ty1' <- lintType ty1 + ; ty2' <- lintType ty2 + ; let k1 = typeKind ty1' + k2 = typeKind ty2' + ; prov' <- lint_prov k1 k2 prov + + ; when (r /= Phantom && isTYPEorCONSTRAINT k1 + && isTYPEorCONSTRAINT k2) + (checkTypes ty1 ty2) + + ; return (UnivCo prov' r ty1' ty2') } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + | allow_ill_kinded_univ_co prov + = return () -- Skip kind checks + | otherwise + = do { checkWarnL fixed_rep_1 + (report "left-hand type does not have a fixed runtime representation") + ; checkWarnL fixed_rep_2 + (report "right-hand type does not have a fixed runtime representation") + ; when (fixed_rep_1 && fixed_rep_2) $ + do { checkWarnL (reps1 `equalLength` reps2) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + fixed_rep_1 = typeHasFixedRuntimeRep t1 + fixed_rep_2 = typeHasFixedRuntimeRep t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + -- CorePrep deliberately makes ill-kinded casts + -- e.g (case error @Int "blah" of {}) :: Int# + -- ==> (error @Int "blah") |> Unsafe Int Int# + -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep + allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind + allow_ill_kinded_univ_co _ = False + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { platform <- getPlatform + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + + lint_prov k1 k2 (PhantomProv kco) + = do { kco' <- lintStarCoercion kco + ; lintRole co Phantom r + ; check_kinds kco' k1 k2 + ; return (PhantomProv kco') } + + lint_prov k1 k2 (ProofIrrelProv kco) + = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) + ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) + ; kco' <- lintStarCoercion kco + ; check_kinds kco k1 k2 + ; return (ProofIrrelProv kco') } + + lint_prov _ _ prov@(PluginProv _) = return prov + lint_prov _ _ prov@(CorePrepProv _) = return prov + + check_kinds kco k1 k2 + = do { let Pair k1' k2' = coercionKind kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } + + +lintCoercion (SymCo co) + = do { co' <- lintCoercion co + ; return (SymCo co') } + +lintCoercion co@(TransCo co1 co2) + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let ty1b = coercionRKind co1' + ty2a = coercionLKind co2' + ; ensureEqTys ty1b ty2a + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')])) + ; lintRole co (coercionRole co1) (coercionRole co2) + ; return (TransCo co1' co2') } + +lintCoercion the_co@(SelCo cs co) + = do { co' <- lintCoercion co + ; 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) + -> 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 + ; let Pair s t = coercionKind co' + r = coercionRole co' + ; lintRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just _, Just _) -> return (LRCo lr co') + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg) + = do { co' <- lintCoercion co + ; arg' <- lintCoercion arg + ; let Pair t1 t2 = coercionKind co' + Pair s1 s2 = coercionKind arg' + + ; lintRole arg Nominal (coercionRole arg') + + ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of + -- forall over tvar + { (Just (tv1,_), Just (tv2,_)) + | typeKind s1 `eqType` tyVarKind tv1 + , typeKind s2 `eqType` tyVarKind tv2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) + + ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of + -- forall over covar + { (Just (cv1, _), Just (cv2, _)) + | typeKind s1 `eqType` varType cv1 + , typeKind s2 `eqType` varType cv2 + , CoercionTy _ <- s1 + , CoercionTy _ <- s2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co) + + ; _ -> failWithL (text "Bad argument of inst") }}} + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) + (bad_ax (text "index out of range")) + ; let CoAxBranch { cab_tvs = ktvs + , cab_cvs = cvs + , cab_roles = roles } = coAxiomNthBranch con ind + ; unless (cos `equalLength` (ktvs ++ cvs)) $ + bad_ax (text "lengths") + ; cos' <- mapM lintCoercion cos + ; subst <- getSubst + ; let empty_subst = zapSubst subst + ; _ <- foldlM check_ki (empty_subst, empty_subst) + (zip3 (ktvs ++ cvs) roles cos') + ; let fam_tc = coAxiomTyCon con + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch + Nothing -> return () + ; return (AxiomInstCo con ind cos') } + where + bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, arg') + = do { let Pair s' t' = coercionKind arg' + sk' = typeKind s' + tk' = typeKind t' + ; lintRole arg' role (coercionRole arg') + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; unless (sk' `eqType` ktv_kind_l) + (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) + ; unless (tk' `eqType` ktv_kind_r) + (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + +lintCoercion (KindCo co) + = do { co' <- lintCoercion co + ; return (KindCo co') } + +lintCoercion (SubCo co') + = do { co' <- lintCoercion co' + ; lintRole co' Nominal (coercionRole co') + ; return (SubCo co') } + +lintCoercion this@(AxiomRuleCo ax cos) + = do { cos' <- mapM lintCoercion cos + ; lint_roles 0 (coaxrAsmpRoles ax) cos' + ; case coaxrProves ax (map coercionKind cos') of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just _ -> return (AxiomRuleCo ax cos') } + where + err :: forall a. String -> [SDoc] -> LintM a + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) + + lint_roles n (e : es) (co : cos) + | e == coercionRole co = lint_roles (n+1) es cos + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr (coercionRole co) ] + lint_roles _ [] [] = return () + lint_roles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lint_roles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (HoleCo h) + = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h + ; lintCoercion (CoVarCo (coHoleCoVar h)) } + +{- +************************************************************************ +* * + Axioms +* * +************************************************************************ +-} + +lintAxioms :: Logger + -> LintConfig + -> SDoc -- ^ The source of the linted axioms + -> [CoAxiom Branched] + -> IO () +lintAxioms logger cfg what axioms = + displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ + initL cfg $ + do { mapM_ lint_axiom axioms + ; let axiom_groups = groupWith coAxiomTyCon axioms + ; mapM_ lint_axiom_group axiom_groups } + +lint_axiom :: CoAxiom Branched -> LintM () +lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches + , co_ax_role = ax_role }) + = addLoc (InAxiom ax) $ + do { mapM_ (lint_branch tc) branch_list + ; extra_checks } + where + branch_list = fromBranches branches + + extra_checks + | isNewTyCon tc + = do { CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs_tys } + <- case branch_list of + [branch] -> return branch + _ -> failWithL (text "multi-branch axiom with newtype") + ; let ax_lhs = mkInfForAllTys tvs $ + mkTyConApp tc lhs_tys + nt_tvs = takeList tvs (tyConTyVars tc) + -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon + nt_lhs = mkInfForAllTys nt_tvs $ + mkTyConApp tc (mkTyVarTys nt_tvs) + -- See Note [Newtype eta] in GHC.Core.TyCon + ; lintL (ax_lhs `eqType` nt_lhs) + (text "Newtype axiom LHS does not match newtype definition") + ; lintL (null cvs) + (text "Newtype axiom binds coercion variables") + ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] + -- which is not about newtype axioms + (text "Newtype axiom has eta-tvs") + ; lintL (ax_role == Representational) + (text "Newtype axiom role not representational") + ; lintL (roles `equalLength` tvs) + (text "Newtype axiom roles list is the wrong length." $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (roles == takeList roles (tyConRoles tc)) + (vcat [ text "Newtype axiom roles do not match newtype tycon's." + , text "axiom roles:" <+> sep (map ppr roles) + , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) + } + + | isFamilyTyCon tc + = do { if | isTypeFamilyTyCon tc + -> lintL (ax_role == Nominal) + (text "type family axiom is not nominal") + + | isDataFamilyTyCon tc + -> lintL (ax_role == Representational) + (text "data family axiom is not representational") + + | otherwise + -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) + + ; mapM_ (lint_family_branch tc) branch_list } + + | otherwise + = addErrL (text "Axiom tycon is neither a newtype nor a family.") + +lint_branch :: TyCon -> CoAxBranch -> LintM () +lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_args, cab_rhs = rhs }) + = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + do { let lhs = mkTyConApp ax_tc lhs_args + ; lhs' <- lintType lhs + ; rhs' <- lintType rhs + ; let lhs_kind = typeKind lhs' + rhs_kind = typeKind rhs' + ; 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 () +lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs + , cab_incomps = incomps }) + = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) + (text "Type family axiom has eta-tvs") + ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) + (text "Quantified variable in family axiom unused in LHS") + ; lintL (all isTyFamFree lhs) + (text "Type family application on LHS of family axiom") + ; lintL (all (== Nominal) roles) + (text "Non-nominal role in family axiom" $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (null cvs) + (text "Coercion variables bound in family axiom") + ; forM_ incomps $ \ br' -> + lintL (not (compatibleBranches br br')) $ + hang (text "Incorrect incompatible branches:") + 2 (vcat [text "Branch:" <+> ppr br, + text "Bogus incomp:" <+> ppr br']) } + +lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () +lint_axiom_group (_ :| []) = return () +lint_axiom_group (ax :| axs) + = do { lintL (isOpenFamilyTyCon tc) + (text "Non-open-family with multiple axioms") + ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs + , ax2 <- all_axs ] + ; mapM_ (lint_axiom_pair tc) all_pairs } + where + all_axs = ax : axs + tc = coAxiomTyCon ax + +lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () +lint_axiom_pair tc (ax1, ax2) + | Just br1@(CoAxBranch { cab_tvs = tvs1 + , cab_lhs = lhs1 + , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 + , Just br2@(CoAxBranch { cab_tvs = tvs2 + , cab_lhs = lhs2 + , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 + = lintL (compatibleBranches br1 br2) $ + vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 + , text "are incompatible" ] + , text "tvs1 =" <+> pprTyVars tvs1 + , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) + , text "rhs1 =" <+> ppr rhs1 + , text "tvs2 =" <+> pprTyVars tvs2 + , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) + , text "rhs2 =" <+> ppr rhs2 ] + + | otherwise + = addErrL (text "Open type family axiom has more than one branch: either" <+> + ppr ax1 <+> text "or" <+> ppr ax2) + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: Subst -- Current TyCo substitution + -- See Note [Linting type lets] + -- /Only/ substitutes for type variables; + -- but might clone CoVars + -- We also use le_subst to keep track of + -- in-scope TyVars and CoVars (but not Ids) + -- Range of the Subst is LintedType/LintedCo + + , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids + -- Used to check that occurrences have an enclosing binder. + -- The Id is /pre-substitution/, used to check that + -- the occurrence has an identical type to the binder + -- The LintedType is used to return the type of the occurrence, + -- without having to lint it again. + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the + -- alias-like binders, as found in + -- non-recursive lets. + + , le_platform :: Platform -- ^ Target platform + , le_diagOpts :: DiagOpts -- ^ Target platform + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] + , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +newtype LintM a = + LintM' { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + LResult a } -- Result and messages (if any) + + +pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern LintM m <- LintM' m + where + LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we) + -- LintM m = LintM' (oneShot $ oneShot m) +{-# COMPLETE LintM #-} + +instance Functor (LintM) where + fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w) + +type WarnsAndErrs = (Bag SDoc, Bag SDoc) + +-- Using a unboxed tuple here reduced allocations for a lint heavy +-- file by ~6%. Using MaybeUB reduced them further by another ~12%. +type LResult a = (# MaybeUB a, WarnsAndErrs #) + +pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a +pattern LResult m w = (# m, w #) +{-# COMPLETE LResult #-} + +mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2 +mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w + +-- Just for testing. +fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a +fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs +fromBoxedLResult (Nothing,errs) = LResult NothingUB errs + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. + +Note [Linting linearity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Core understands linear types: linearity is checked with the flag +`-dlinear-core-lint`. Why not make `-dcore-lint` check linearity? Because +optimisation passes are not (yet) guaranteed to maintain linearity. They should +do so semantically (GHC is careful not to duplicate computation) but it is much +harder to ensure that the statically-checkable constraints of Linear Core are +maintained. The current Linear Core is described in the wiki at: +https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation. + +Why don't the optimisation passes maintain the static types of Linear Core? +Because doing so would cripple some important optimisations. Here is an +example: + + data T = MkT {-# UNPACK #-} !Int + +The wrapper for MkT is + + $wMkT :: Int %1 -> T + $wMkT n = case %1 n of + I# n' -> MkT n' + +This introduces, in particular, a `case %1` (this is not actual Haskell or Core +syntax), where the `%1` means that the `case` expression consumes its scrutinee +linearly. + +Now, `case %1` interacts with the binder swap optimisation in a non-trivial +way. Take a slightly modified version of the code for $wMkT: + + case %1 x of z { + I# n' -> (x, n') + } + +Binder-swap wants to change this to + + case %1 x of z { + I# n' -> let x = z in (x, n') + } + +Now, this is not something that a linear type checker usually considers +well-typed. It is not something that `-dlinear-core-lint` considers to be +well-typed either. But it's only because `-dlinear-core-lint` is not good +enough. However, making `-dlinear-core-lint` recognise this expression as valid +is not obvious. There are many such interactions between a linear type system +and GHC optimisations documented in the linear-type implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]. + +PRINCIPLE: The type system bends to the optimisation, not the other way around. + +In the original linear-types implementation, we had tried to make every +optimisation pass produce code that passes `-dlinear-core-lint`. It had proved +very difficult. And we kept finding corner case after corner case. Plus, we +used to restrict transformations when `-dlinear-core-lint` couldn't typecheck +the result. There are still occurrences of such restrictions in the code. But +our current stance is that such restrictions can be removed. + +For instance, some optimisations can create a letrec which uses a variable +linearly, e.g. + + letrec f True = f False + f False = x + in f True + +uses 'x' linearly, but this is not seen by the linter. This issue is discussed +in ticket #18694. + +Plus in many cases, in order to make a transformation compatible with linear +linting, we ended up restricting to avoid producing patterns that were not +recognised as linear by the linter. This violates the above principle. + +In the future, we may be able to lint the linearity of the output of +Core-to-Core passes (#19165). But right now, we can't. Therefore, in virtue of +the principle above, after the desguarer, the optimiser should take no special +pains to preserve linearity (in the type system sense). + +In general the optimiser tries hard not to lose sharing, so it probably doesn't +actually make linear things non-linear. We postulate that any program +transformation which breaks linearity would negatively impact performance, and +therefore wouldn't be suitable for an optimiser. An alternative to linting +linearity after each pass is to prove this statement. + +There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123 + +Note [checkCanEtaExpand] +~~~~~~~~~~~~~~~~~~~~~~~~ +The checkCanEtaExpand function is responsible for enforcing invariant I3 +from Note [Representation polymorphism invariants] in GHC.Core: in any +partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to +eta expand `f` to match the declared arity of `f`. + +Wrinkle 1: eta-expansion and newtypes + + Most of the time, when we have a partial application `f e_1 .. e_n` + in which `f` is `hasNoBinding`, we eta-expand it up to its arity + as follows: + + \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity + + However, we might need to insert casts if some of the arguments + that `f` takes are under a newtype. + For example, suppose `f` `hasNoBinding`, has arity 1 and type + + f :: forall r (a :: TYPE r). Identity (a -> a) + + then we eta-expand the nullary application `f` to + + ( \ x -> f x ) |> co + + where + + co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) ) + + In this case we would have to perform a representation-polymorphism check on the instantiation + of `a`. + +Wrinkle 2: 'hasNoBinding' and laziness + + It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing + the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in + Note [Lazily checking Unfoldings] in GHC.IfaceToCore. +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> LResult (JustUB x) errs + --(Just x, errs) + (<*>) = ap + +instance Monad LintM where + m >>= k = LintM (\ env errs -> + let res = unLintM m env errs in + case res of + LResult (JustUB r) errs' -> unLintM (k r) env errs' + LResult NothingUB errs' -> LResult NothingUB errs' + ) + -- LError errs'-> LError errs') + -- let (res, errs') = unLintM m env errs in + -- Just r -> unLintM (k r) env errs' + -- Nothing -> (Nothing, errs')) + +instance MonadFail LintM where + fail err = failWithL (text err) + +getPlatform :: LintM Platform +getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | OccOf Id -- Occurrence of id + | LambdaBodyOf Id -- The lambda-binder + | RuleOf Id -- Rules attached to a binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + | InAxiom (CoAxiom Branched) -- Inside a CoAxiom + +data LintConfig = LintConfig + { l_diagOpts :: !DiagOpts -- ^ Diagnostics opts + , l_platform :: !Platform -- ^ Target platform + , l_flags :: !LintFlags -- ^ Linting the result of this pass + , l_vars :: ![Var] -- ^ 'Id's that should be treated as being in scope + } + +initL :: LintConfig + -> LintM a -- ^ Action to run + -> WarnsAndErrs +initL cfg m + = case unLintM m env (emptyBag, emptyBag) of + LResult (JustUB _) errs -> errs + LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + (tcvs, ids) = partition isTyCoVar $ l_vars cfg + env = LE { le_flags = l_flags cfg + , le_subst = mkEmptySubst (mkInScopeSetList tcvs) + , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] + , le_joins = emptyVarSet + , le_loc = [] + , le_ue_aliases = emptyNameEnv + , le_platform = l_platform cfg + , le_diagOpts = l_diagOpts cfg + } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for representation polymorphism] +noFixedRuntimeRepChecks :: LintM a -> LintM a +noFixedRuntimeRepChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) + +checkL :: Bool -> SDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> SDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> SDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: SDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: SDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: SDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (addMsg False env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc +addMsg is_error env msgs msg + = assertPpr (notNull loc_msgs) msg $ + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + context | is_error = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + !diag_opts = le_diagOpts env + mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeId :: Id -> LintedType -> LintM a -> LintM a +addInScopeId id linted_ty m + = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs -> + unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) + , le_joins = add_joins join_set }) errs + where + add_joins join_set + | isJoinId id = extendVarSet join_set id -- Overwrite with new arity + | otherwise = delVarSet join_set id -- Remove any existing binding + +getInScopeIds :: LintM (VarEnv (Id,LintedType)) +getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs)) + +extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a +extendTvSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +updateSubst :: Subst -> LintM a -> LintM a +updateSubst subst' m + = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) + +getSubst :: LintM Subst +getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) + +getUEAliases :: LintM (NameEnv UsageEnv) +getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs)) + +lookupIdInScope :: Id -> LintM (Id, LintedType) +lookupIdInScope id_occ + = do { in_scope_ids <- getInScopeIds + ; case lookupVarEnv in_scope_ids id_occ of + Just (id_bndr, linted_ty) + -> do { checkL (not (bad_global id_bndr)) global_in_scope + ; return (id_bndr, linted_ty) } + Nothing -> do { checkL (not is_local) local_out_of_scope + ; return (id_occ, idType id_occ) } } + -- We don't bother to lint the type + -- of global (i.e. imported) Ids + where + is_local = mustHaveLocalBinding id_occ + local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ + global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (pprBndr LetBind id_occ) + bad_global id_bnd = isGlobalId id_occ + && isLocalId id_bnd + && not (isWiredIn id_occ) + -- 'bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + +lookupJoinId :: Id -> LintM (Maybe JoinArity) +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (isJoinId_maybe id') + Nothing -> return Nothing } + +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a +addAliasUE id ue thing_inside = LintM $ \ env errs -> + let new_ue_aliases = + extendNameEnv (le_ue_aliases env) (getName id) ue + in + unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs + +varCallSiteUsage :: Id -> LintM UsageEnv +varCallSiteUsage id = + do m <- getUEAliases + return $ case lookupNameEnv m (getName id) of + Nothing -> unitUE id OneTy + Just id_ue -> id_ue + +ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg + +ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () +ensureSubUsage Bottom _ _ = return () +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 () +ensureSubMult actual_mult described_mult err_msg = do + flags <- getLintFlags + when (lf_check_linearity flags) $ + unless (deepSubMult actual_mult described_mult) $ + addErrL err_msg + where + -- Check for submultiplicity using the following rules: + -- 1. x*y <= z when x <= z and y <= z. + -- This rule follows from the fact that x*y = sup{x,y} for any + -- multiplicities x,y. + -- 2. x <= y*z when x <= y or x <= z. + -- This rule is not complete: when x = y*z, we cannot + -- change y*z <= y*z to y*z <= y or y*z <= z. + -- However, we eliminate products on the LHS in step 1. + -- 3. One <= x and x <= Many for any x, as checked by 'submult'. + -- 4. x <= x. + -- Otherwise, we fail. + deepSubMult :: Mult -> Mult -> Bool + deepSubMult m n + | Just (m1, m2) <- isMultMul m = deepSubMult m1 n && deepSubMult m2 n + | Just (n1, n2) <- isMultMul n = deepSubMult m n1 || deepSubMult m n2 + | Submult <- m `submult` n = True + | otherwise = m `eqType` n + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (OccOf v) + = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (RuleOf b) + = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(b:_)) + = ( getSrcLoc b, text "In the body of letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (Alt con args _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (Alt con args _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) +dumpLoc (InAxiom ax) + = (getSrcLoc ax, hang (text "In the coercion axiom") + 2 (pprCoAxiom ax)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> SDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> Subst -> SDoc +mkScrutMsg var var_ty scrut_ty subst + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty, + hsep [text "Current TCv subst", ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> SDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> SDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> SDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: SDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> SDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkAppMsg expected_arg_ty actual_arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Expected arg type:") 4 (ppr expected_arg_ty), + hang (text "Actual arg type:") 4 (ppr actual_arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> SDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> SDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Exp type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> SDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> SDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +badBndrTyMsg :: Id -> SDoc -> SDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkNonTopExportedMsg :: Id -> SDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> SDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> SDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> SDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> SDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc +mkBadUnivCoMsg lr co + = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> + text "side of a UnivCo:" <+> ppr co + +mkBadProofIrrelMsg :: Type -> Coercion -> SDoc +mkBadProofIrrelMsg ty co + = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") + 2 (vcat [ text "type:" <+> ppr ty + , text "co:" <+> ppr co ]) + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar n rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr (ar - n), + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc +mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty + , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty + , text " Before subst:" <+> ppr (idType var) ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] + +pprLeftOrRight :: LeftOrRight -> SDoc +pprLeftOrRight CLeft = text "left" +pprLeftOrRight CRight = text "right" + +dupVars :: [NonEmpty Var] -> SDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> SDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do + -- Run the pass as we normally would + dflags <- getDynFlags + logger <- getLogger + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass logger "Annotation linting - first run" + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + if gopt Opt_DoAnnotationLinting dflags + then do + nguts <- pass guts + liftIO $ Err.showPass logger "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass logger "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs + ] + return nguts + else + pass guts + +-- | Run the given pass without annotations. This means that we both +-- set the debugLevel setting to 0 in the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + -- TODO: supply tag here as well ? + let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 } + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of debugLevel > 0. + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied. Drop the simple count so it doesn't + -- effect the total also + dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/compiler/GHC/Core/Lint/Interactive.hs b/compiler/GHC/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Lint/Interactive.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint.Interactive ( + interactiveInScope, + ) where + +import GHC.Prelude + +import GHC.Runtime.Context + +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs +import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) + +import GHC.Types.Id +import GHC.Types.TypeEnv + + +interactiveInScope :: InteractiveContext -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope ictxt + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs --- 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,35 +23,30 @@ FloatBind(..), wrapFloat, wrapFloats, floatBindings, -- * Constructing small tuples - mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum, + mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, 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, -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, - rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, + rEC_CON_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,24 +54,24 @@ 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 +import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Types.Demand import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal import GHC.Types.Unique.Supply import GHC.Core -import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) +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 +81,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString import Data.List ( partition ) @@ -105,7 +99,7 @@ -- | Sort the variables, putting type and covars first, in scoped order, -- and then other Ids -- --- It is a deterministic sort, meaining it doesn't look at the values of +-- It is a deterministic sort, meaning it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] -- in GHC.Types.Unique. sortQuantVars :: [Var] -> [Var] @@ -115,9 +109,9 @@ sorted_tcvs = scopedSort tcvs -- | Bind a binding group over an expression, using a @let@ or @case@ as --- appropriate (see "GHC.Core#let_app_invariant") +-- appropriate (see "GHC.Core#let_can_float_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr -mkCoreLet (NonRec bndr rhs) body -- See Note [Core let/app invariant] +mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant] = bindNonRec bndr rhs body mkCoreLet bind body = Let bind body @@ -141,9 +135,6 @@ -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreApps :: CoreExpr -- ^ function -> [CoreExpr] -- ^ arguments -> CoreExpr @@ -156,9 +147,6 @@ -- | Construct an expression which represents the application of one expression -- to the other --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreApp :: SDoc -> CoreExpr -- ^ function -> CoreExpr -- ^ argument @@ -170,9 +158,6 @@ -- paired with its type to an argument. The result is paired with its type. This -- function is not exported and used in the definition of 'mkCoreApp' and -- 'mkCoreApps'. --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) mkCoreAppTyped _ (fun, fun_ty) (Type ty) = (App fun (Type ty), piResultTy fun_ty ty) @@ -180,20 +165,7 @@ = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) - (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty) - where - (mult, arg_ty, res_ty) = splitFunTy fun_ty - --- | Build an application (e1 e2), --- or a strict binding (case e2 of x -> e1 x) --- using the latter when necessary to respect the let/app invariant --- See Note [Core let/app invariant] in GHC.Core -mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -mkValApp fun arg (Scaled w arg_ty) res_ty - | not (needsCaseBinding arg_ty arg) - = App fun arg -- The vastly common case - | otherwise - = mkStrictApp fun arg (Scaled w arg_ty) res_ty + (App fun arg, funResultTy fun_ty) {- ********************************************************************* * * @@ -202,7 +174,7 @@ ********************************************************************* -} 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 @@ -225,25 +197,6 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts = Case scrut (mkWildValBinder w scrut_ty) res_ty alts --- | Build a strict application (case e2 of x -> e1 x) -mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -mkStrictApp fun arg (Scaled w arg_ty) res_ty - = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))] - -- mkDefaultCase looks attractive here, and would be sound. - -- But it uses (exprType alt_rhs) to compute the result type, - -- whereas here we already know that the result type is res_ty - where - arg_id = mkWildValBinder w arg_ty - -- Lots of shadowing, but it doesn't matter, - -- because 'fun' and 'res_ty' should not have a free wild-id - -- - -- This is Dangerous. But this is the only place we play this - -- game, mkStrictApp returns an expression that does not have - -- a free wild-id. So the only way 'fun' could get a free wild-id - -- would be if you take apart this case expression (or some other - -- expression that uses mkWildValBinder, of which there are not - -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. - mkIfThenElse :: CoreExpr -- ^ guard -> CoreExpr -- ^ then -> CoreExpr -- ^ else @@ -260,7 +213,7 @@ -- 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 @@ -277,9 +230,9 @@ | 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) {- ************************************************************************ @@ -302,7 +255,7 @@ mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLit platform (fromIntegral i)] --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value mkWordExpr :: Platform -> Integer -> CoreExpr mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] @@ -374,22 +327,12 @@ {- ************************************************************************ * * -\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) @@ -400,8 +343,8 @@ 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. @@ -419,47 +362,52 @@ 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. -- -- Alternative number ("alt") starts from 1. -mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr -mkCoreUbxSum arity alt tys exp +mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr +mkCoreUnboxedSum arity alt tys exp = assert (length tys == arity) $ assert (alt <= arity) $ mkCoreConApps (sumDataCon alt arity) @@ -467,37 +415,153 @@ ++ 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) + + {- ************************************************************************ * * @@ -506,7 +570,7 @@ ************************************************************************ -} --- | Builds a selector which scrutises the given +-- | Builds a selector which scrutinises the given -- expression and extracts the one name from the list given. -- If you want the no-shadowing rule to apply, the caller -- is responsible for making sure that none of these names @@ -518,16 +582,16 @@ -- 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 }} @@ -538,7 +602,7 @@ -- 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 @@ -547,18 +611,18 @@ 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 } |] @@ -581,45 +645,71 @@ 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') + = (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) --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed + 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 @@ -631,7 +721,6 @@ 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] @@ -694,9 +783,6 @@ 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 @@ -724,7 +810,7 @@ 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) @@ -762,7 +848,9 @@ -} mkRuntimeErrorApp - :: Id -- Should be of type (forall a. Addr# -> a) + :: Id -- Should be of type + -- forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + -- or (a :: CONSTRAINT r) -- where Addr# points to a UTF8 encoded string -> Type -- The type to instantiate 'a' -> String -- The string to print @@ -774,10 +862,6 @@ where err_string = Lit (mkLitString err_msg) -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - {- ************************************************************************ * * @@ -799,29 +883,23 @@ errorIds :: [Id] errorIds - = [ rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, + = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, rEC_SEL_ERROR_ID, - aBSENT_ERROR_ID, + iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID, + aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID, - tYPE_ERROR_ID, -- Used with Opt_DeferTypeErrors, see #10284 - rAISE_OVERFLOW_ID, - rAISE_UNDERFLOW_ID, - rAISE_DIVZERO_ID + tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 ] -recSelErrorName, runtimeErrorName, absentErrorName :: Name -recConErrorName, patErrorName :: Name +recSelErrorName, recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name absentSumFieldErrorName :: Name -raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID @@ -834,17 +912,15 @@ err_nm :: String -> Unique -> Id -> Name 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 +rEC_SEL_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 -rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName +tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId TypeLike recSelErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId TypeLike recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId TypeLike patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId TypeLike noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId TypeLike typeErrorName -- Note [aBSENT_SUM_FIELD_ERROR_ID] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -945,38 +1021,7 @@ absentSumFieldErrorIdKey aBSENT_SUM_FIELD_ERROR_ID -absentErrorName - = mkWiredInIdName - gHC_PRIM_PANIC - (fsLit "absentError") - absentErrorIdKey - aBSENT_ERROR_ID - -raiseOverflowName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseOverflow") - raiseOverflowIdKey - rAISE_OVERFLOW_ID - -raiseUnderflowName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseUnderflow") - raiseUnderflowIdKey - rAISE_UNDERFLOW_ID - -raiseDivZeroName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseDivZero") - raiseDivZeroIdKey - rAISE_DIVZERO_ID - aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName -rAISE_OVERFLOW_ID = mkExceptionId raiseOverflowName -rAISE_UNDERFLOW_ID = mkExceptionId raiseUnderflowName -rAISE_DIVZERO_ID = mkExceptionId raiseDivZeroName -- | Exception with type \"forall a. a\" -- @@ -989,31 +1034,7 @@ (divergingIdInfo [] `setCafInfo` NoCafRefs) -- See Note [Wired-in exceptions are not CAFfy] -mkRuntimeErrorId :: Name -> Id --- Error function --- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a --- with arity: 1 --- which diverges after being given one argument --- The Addr# is expected to be the address of --- a UTF8-encoded error string -mkRuntimeErrorId name - = mkVanillaGlobalWithInfo name runtimeErrorTy (divergingIdInfo [evalDmd]) - -- Do *not* mark them as NoCafRefs, because they can indeed have - -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, - -- which has some CAFs - -- In due course we may arrange that these error-y things are - -- regarded by the GC as permanently live, in which case we - -- can give them NoCaf info. As it is, any function that calls - -- any pc_bottoming_Id will itself have CafRefs, which bloats - -- SRTs. - -runtimeErrorTy :: Type --- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a --- See Note [Error and friends have an "open-tyvar" forall] -runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] - (mkVisFunTyMany addrPrimTy openAlphaTy) - --- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', that +-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that -- throws an (imprecise) exception after being supplied one value arg for every -- argument 'Demand' in the list. The demands end up in the demand signature. -- @@ -1042,6 +1063,56 @@ ************************************************************************ * * + iMPOSSIBLE_ERROR_ID +* * +************************************************************************ +-} + +iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id +iMPOSSIBLE_ERROR_ID = mkRuntimeErrorId TypeLike impossibleErrorName +iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName + +impossibleErrorName, impossibleConstraintErrorName :: Name +impossibleErrorName = err_nm "impossibleError" + impossibleErrorIdKey iMPOSSIBLE_ERROR_ID +impossibleConstraintErrorName = err_nm "impossibleConstraintError" + impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID + +mkImpossibleExpr :: Type -> String -> CoreExpr +mkImpossibleExpr res_ty str + = mkRuntimeErrorApp err_id res_ty str + where -- See Note [Type vs Constraint for error ids] + err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID + | otherwise = iMPOSSIBLE_ERROR_ID + +{- Note [Type vs Constraint for error ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need both + iMPOSSIBLE_ERROR_ID :: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a + +because we don't have polymorphism over TYPE vs CONSTRAINT. You +might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in +practice, but it is: see #22634. So: + +* In Control.Exception.Base we have + impossibleError :: forall (a::Type). Addr# -> a + impossibleConstraintError :: forall (a::Type). Addr# -> a + This generates the code for `impossibleError`, but because they are wired in + the interface file definitions are never looked at (indeed, they don't + even get serialised). + +* In this module GHC.Core.Make we define /wired-in/ Ids for + iMPOSSIBLE_ERROR_ID + iMPOSSIBLE_CONSTRAINT_ERROR_ID + with the desired above types (i.e. runtime-rep polymorphic, and returning a + constraint for the latter. + +Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID + + +************************************************************************ +* * aBSENT_ERROR_ID * * ************************************************************************ @@ -1122,19 +1193,92 @@ 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 +-- See Note [Type vs Constraint for error ids] 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 -- See Note [Type vs Constraint for error ids] + = 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] + = mk_runtime_error_id absentErrorName absent_ty + 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 + +aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mk_runtime_error_id absentConstraintErrorName absent_ty + -- See Note [Type vs Constraint for error ids] + where + -- absentConstraintError :: forall (a :: Constraint). Addr# -> a + absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy + addrPrimTy (mkTyVarTy alphaConstraintTyVar) + + +{- +************************************************************************ +* * + mkRuntimeErrorId +* * +************************************************************************ +-} + +mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id +-- Error function +-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a +-- with arity: 1 +-- which diverges after being given one argument +-- The Addr# is expected to be the address of +-- a UTF8-encoded error string +mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc) + + +mk_runtime_error_id :: Name -> Type -> Id +mk_runtime_error_id name ty + = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd]) + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + +mkRuntimeErrorTy :: TypeOrConstraint -> Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $ + mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar) + where + (tyvar:_) = mkTemplateTyVars [kind] + kind = case torc of + TypeLike -> mkTYPEapp runtimeRep1Ty + ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty + diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -109,13 +109,17 @@ -- is the type you want. newtype CoreMap a = CoreMap (CoreMapG a) +-- TODO(22292): derive +instance Functor CoreMap where + fmap f = \ (CoreMap m) -> CoreMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap CoreMap where type Key CoreMap = CoreExpr emptyTM = CoreMap emptyTM lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) foldTM k (CoreMap m) = foldTM k m - mapTM f (CoreMap m) = CoreMap (mapTM f m) filterTM f (CoreMap m) = CoreMap (filterTM f m) -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended @@ -146,9 +150,8 @@ 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 @@ -159,7 +162,6 @@ && 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) @@ -171,9 +173,7 @@ 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 @@ -248,30 +248,27 @@ , cm_letr = emptyTM, cm_case = emptyTM , cm_ecase = emptyTM, cm_tick = emptyTM } +-- TODO(22292): derive +instance Functor CoreMapX where + fmap f CM + { cm_var = cvar, cm_lit = clit, cm_co = cco, cm_type = ctype, cm_cast = ccast + , cm_app = capp, cm_lam = clam, cm_letn = cletn, cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick } = CM + { cm_var = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype + , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam + , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr + , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase + , cm_tick = fmap (fmap f) ctick } + instance TrieMap CoreMapX where type Key CoreMapX = DeBruijn CoreExpr emptyTM = emptyE lookupTM = lkE alterTM = xtE foldTM = fdE - mapTM = mapE filterTM = ftE -------------------------- -mapE :: (a->b) -> CoreMapX a -> CoreMapX b -mapE f (CM { cm_var = cvar, cm_lit = clit - , cm_co = cco, cm_type = ctype - , cm_cast = ccast , cm_app = capp - , cm_lam = clam, cm_letn = cletn - , cm_letr = cletr, cm_case = ccase - , cm_ecase = cecase, cm_tick = ctick }) - = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit - , cm_co = mapTM f cco, cm_type = mapTM f ctype - , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp - , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn - , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase - , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } - ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a ftE f (CM { cm_var = cvar, cm_lit = clit , cm_co = cco, cm_type = ctype @@ -281,10 +278,10 @@ , cm_ecase = cecase, cm_tick = ctick }) = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit , cm_co = filterTM f cco, cm_type = filterTM f ctype - , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp - , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn - , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase - , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick } + , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp + , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn + , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase + , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick } -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a @@ -394,6 +391,11 @@ , am_data :: DNameEnv (CoreMapG a) , am_lit :: LiteralMap (CoreMapG a) } +-- TODO(22292): derive +instance Functor AltMap where + fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM + { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit } + instance TrieMap AltMap where type Key AltMap = CoreAlt emptyTM = AM { am_deflt = emptyTM @@ -402,7 +404,6 @@ lookupTM = lkA emptyCME alterTM = xtA emptyCME foldTM = fdA - mapTM = mapA filterTM = ftA instance Eq (DeBruijn CoreAlt) where @@ -416,17 +417,11 @@ D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False -mapA :: (a->b) -> AltMap a -> AltMap b -mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) - = AM { am_deflt = mapTM f adeflt - , am_data = mapTM (mapTM f) adata - , am_lit = mapTM (mapTM f) alit } - ftA :: (a->Bool) -> AltMap a -> AltMap a ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) = AM { am_deflt = filterTM f adeflt - , am_data = mapTM (filterTM f) adata - , am_lit = mapTM (filterTM f) alit } + , am_data = fmap (filterTM f) adata + , am_lit = fmap (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -38,6 +38,7 @@ 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.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) @@ -83,25 +83,33 @@ -- just look up the coercion's type. newtype CoercionMap a = CoercionMap (CoercionMapG a) +-- TODO(22292): derive +instance Functor CoercionMap where + fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap CoercionMap where type Key CoercionMap = Coercion emptyTM = CoercionMap emptyTM lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) foldTM k (CoercionMap m) = foldTM k m - mapTM f (CoercionMap m) = CoercionMap (mapTM f m) filterTM f (CoercionMap m) = CoercionMap (filterTM f m) type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) +-- TODO(22292): derive +instance Functor CoercionMapX where + fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm) + {-# INLINE fmap #-} + instance TrieMap CoercionMapX where type Key CoercionMapX = DeBruijn Coercion emptyTM = CoercionMapX emptyTM lookupTM = lkC alterTM = xtC foldTM f (CoercionMapX core_tm) = foldTM f core_tm - mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) instance Eq (DeBruijn Coercion) where @@ -141,13 +149,6 @@ = 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 @@ -157,54 +158,40 @@ -- | 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_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_forall = fmap (fmap f) tforall + , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce } + instance TrieMap TypeMapX where type Key TypeMapX = DeBruijn Type emptyTM = emptyT lookupTM = lkT alterTM = xtT foldTM = fdT - mapTM = mapT filterTM = filterT 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: 'eqExpr' is conservative: if `eqExpr e1 e2` returns -'True', thne it must be that `e1` behaves identically to `e2` in all contexts. -But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of -'tcView' where we expect 'coreView' means 'eqExpr' 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@ @@ -246,9 +233,8 @@ | 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 @@ -258,9 +244,9 @@ (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') @@ -276,16 +262,19 @@ (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 {}) -> TEQ _ -> TNEQ - gos _ _ [] [] = TEQ + -- These bangs make 'gos' strict in the CMEnv, which in turn + -- keeps the CMEnv unboxed across the go/gos mutual recursion + -- (If you want a test case, T9872c really exercises this code.) + gos !_ !_ [] [] = TEQ gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq` gos e1 e2 tys1 tys2 gos _ _ _ _ = TNEQ @@ -308,23 +297,10 @@ emptyT = TM { tm_var = emptyTM , tm_app = emptyTM , tm_tycon = emptyDNameEnv - , tm_funty = emptyTM , tm_forall = emptyTM , tm_tylit = emptyTyLitMap , tm_coerce = Nothing } -mapT :: (a->b) -> TypeMapX a -> TypeMapX b -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit - , tm_coerce = tcoerce }) - = TM { tm_var = mapTM f tvar - , tm_app = mapTM (mapTM f) tapp - , tm_tycon = mapTM f ttycon - , tm_funty = mapTM (mapTM (mapTM f)) tfunty - , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit - , tm_coerce = fmap f tcoerce } - ----------------- lkT :: DeBruijn Type -> TypeMapX a -> Maybe a lkT (D env ty) m = go ty m @@ -334,19 +310,17 @@ 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 @@ -355,16 +329,15 @@ 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) @@ -372,20 +345,18 @@ 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 = mapTM (filterTM f) tapp + , tm_app = fmap (filterTM f) tapp , tm_tycon = filterTM f ttycon - , tm_funty = mapTM (mapTM (filterTM f)) tfunty - , tm_forall = mapTM (filterTM f) tforall + , tm_forall = fmap (filterTM f) tforall , tm_tylit = filterTM f tlit , tm_coerce = filterMaybe f tcoerce } @@ -395,22 +366,22 @@ , tlm_char :: Map.Map Char a } +-- TODO(22292): derive +instance Functor TyLitMap where + fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM + { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + instance TrieMap TyLitMap where type Key TyLitMap = TyLit emptyTM = emptyTyLitMap lookupTM = lkTyLit alterTM = xtTyLit foldTM = foldTyLit - mapTM = mapTyLit filterTM = filterTyLit emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } -mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b -mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } - lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of @@ -439,6 +410,11 @@ -- is the type you want. The keys in this map may have different kinds. newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) +-- TODO(22292): derive +instance Functor TypeMap where + fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m) + {-# INLINE fmap #-} + lkTT :: DeBruijn Type -> TypeMap a -> Maybe a lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m >>= lkG (D env ty) @@ -456,8 +432,7 @@ lookupTM k m = lkTT (deBruijnize k) m alterTM k f m = xtTT (deBruijnize k) f m foldTM k (TypeMap m) = foldTM (foldTM k) m - mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) - filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m) + filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m) foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z @@ -488,16 +463,19 @@ -- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), -- you'll find entries inserted under (t), even if (g) is non-reflexive. -newtype LooseTypeMap a - = LooseTypeMap (TypeMapG a) +newtype LooseTypeMap a = LooseTypeMap (TypeMapG a) +-- TODO(22292): derive +instance Functor LooseTypeMap where + fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap LooseTypeMap where type Key LooseTypeMap = Type emptyTM = LooseTypeMap emptyTM lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) foldTM f (LooseTypeMap m) = foldTM f m - mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) {- @@ -566,18 +544,19 @@ -- of pairs are composition. data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a)) +-- TODO(22292): derive +instance Functor BndrMap where + fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm) + {-# INLINE fmap #-} + instance TrieMap BndrMap where type Key BndrMap = Var emptyTM = BndrMap emptyTM lookupTM = lkBndr emptyCME alterTM = xtBndr emptyCME foldTM = fdBndrMap - mapTM = mapBndrMap filterTM = ftBndrMap -mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b -mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm) - fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm @@ -596,24 +575,23 @@ BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a -ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm) +ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm) --------- Variable occurrence ------------- data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable , vm_fvar :: DVarEnv a } -- Free variable +-- TODO(22292): derive +instance Functor VarMap where + fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv } + instance TrieMap VarMap where type Key VarMap = Var emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } lookupTM = lkVar emptyCME alterTM = xtVar emptyCME foldTM = fdVar - mapTM = mapVar filterTM = ftVar - -mapVar :: (a->b) -> VarMap a -> VarMap b -mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) - = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v diff --git a/compiler/GHC/Core/Multiplicity.hs b/compiler/GHC/Core/Multiplicity.hs --- a/compiler/GHC/Core/Multiplicity.hs +++ b/compiler/GHC/Core/Multiplicity.hs @@ -11,8 +11,8 @@ -} module GHC.Core.Multiplicity ( Mult - , pattern One - , pattern Many + , pattern OneTy + , pattern ManyTy , isMultMul , mkMultAdd , mkMultMul @@ -29,14 +29,16 @@ , 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) @@ -49,22 +51,30 @@ [https://arxiv.org/abs/1710.09756]. Other important resources in the linear types implementation wiki page [https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the -proposal [https://github.com/ghc-proposals/ghc-proposals/pull/111] which +proposal [https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst] which describes the concrete design at length. For the busy developer, though, here is a high-level view of linear types is the following: - Function arrows are annotated with a multiplicity (as defined by type `Mult` and its smart constructors in this module) - - Because, as a type constructor, the type of function now has an extra - argument, the notation (->) is no longer suitable. We named the function - type constructor `FUN`. - - (->) retains its backward compatible meaning: `(->) a b = a -> b`. To - achieve this, `(->)` is defined as a type synonym to `FUN Many` (see + - Multiplicities, in Haskell, are types of kind `GHC.Types.Multiplicity`. + as in + + map :: forall (p :: Multiplicity). (a %p -> b) -> [a] %p -> [b] + + - The type constructor for function types (FUN) has type + + FUN :: forall (m :: Multiplicity) -> forall {r1) {r2}. TYPE r1 -> TYPE r2 -> Type + + The argument order is explained in https://gitlab.haskell.org/ghc/ghc/-/issues/20164 + - (->) retains its backward compatible meaning: + + (->) a b = a -> b = a %'Many -> b + + To achieve this, `(->)` is defined as a type synonym to `FUN Many` (see below). -- Multiplicities can be reified in Haskell as types of kind - `GHC.Types.Multiplicity` -- Ground multiplicity (that is, without a variable) can be `One` or `Many` +- A ground multiplicity (that is, without a variable) can be `One` or `Many` (`Many` is generally rendered as ω in the scientific literature). Functions whose type is annotated with `One` are linear functions, functions whose type is annotated with `Many` are regular functions, often called “unrestricted” @@ -73,19 +83,9 @@ consumed exactly once, *then* its argument is consumed exactly once. You can think of “consuming exactly once” as evaluating a value in normal form exactly once (though not necessarily in one go). The _Linear Haskell_ article (see - infra) has a more precise definition of “consuming exactly once”. -- Data types can have unrestricted fields (the canonical example being the - `Unrestricted` data type), then these don't need to be consumed for a value to - be consumed exactly once. So consuming a value of type `Unrestricted` exactly - once means forcing it at least once. -- Why “at least once”? Because if `case u of { C x y -> f (C x y) }` is linear - (provided `f` is a linear function). So we might as well have done `case u of - { !z -> f z }`. So, we can observe constructors as many times as we want, and - we are actually allowed to force the same thing several times because laziness - means that we are really forcing a the value once, and observing its - constructor several times. The type checker and the linter recognise some (but - not all) of these multiple forces as indeed linear. Mostly just enough to - support variable patterns. + supra) has a more precise definition of “consuming exactly once”. +- Data constructors are linear by default. + See Note [Data constructors are linear by default]. - Multiplicities form a semiring. - Multiplicities can also be variables and we can universally quantify over these variables. This is referred to as “multiplicity @@ -100,6 +100,8 @@ multiplicity `Many` can consume its scrutinee as many time as it wishes (no matter how much the case expression is consumed). +For linear types in the linter see Note [Linting linearity] in GHC.Core.Lint. + Note [Usages] ~~~~~~~~~~~~~ In the _Linear Haskell_ paper, you'll find typing rules such as these: @@ -132,7 +134,7 @@ Usages are usually group in a UsageEnv, as defined in the UsageEnv module. So, in our function application example, the typechecking algorithm would -receive usage environements f_ue from the typechecking of f, and u_ue from the +receive usage environments f_ue from the typechecking of f, and u_ue from the typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and scaling of usage environment is the pointwise extension of the semiring operations on multiplicities. @@ -206,8 +208,8 @@ Note [Data constructors are linear by default] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data constructors defined without -XLinearTypes (as well as data constructors -defined with the Haskell 98 in all circumstances) have all their fields linear. +All data constructors defined without -XLinearTypes, as well as data constructors +defined with the Haskell 98 in all circumstances, have all their fields linear. That is, in @@ -217,10 +219,52 @@ Just :: a %1 -> Just a +Irrespective of whether -XLinearTypes is turned on or not. Furthermore, when +-XLinearTypes is turned off, the declaration + + data Endo a where { MkIntEndo :: (Int -> Int) -> T Int } + +gives + + MkIntEndo :: (Int -> Int) %1 -> T Int + +With -XLinearTypes turned on, instead, this would give + + data EndoU a where { MkIntEndoU :: (Int -> Int) -> T Int } + MkIntEndoU :: (Int -> Int) -> T Int + +With -XLinearTypes turned on, to get a linear field with GADT syntax we +would need to write + + data EndoL a where { MkIntEndoL :: (Int -> Int) %1 -> T Int } + The goal is to maximise reuse of types between linear code and traditional code. This is argued at length in the proposal and the article (links in Note [Linear types]). +Unrestricted field don't need to be consumed for a value to be consumed exactly +once. So consuming a value of type `IntEndoU a` exactly once means forcing it at +least once. + +Why “at least once”? Because if `case u of { MkIntEndoL x -> f (MkIntEndoL x) }` +is linear (provided `f` is a linear function). But we might as well have done +`case u of { !z -> f z }`. So, we can observe constructors as many times as we +want, and we are actually allowed to force the same thing several times because +laziness means that we are really forcing the value once, and observing its +constructor several times. The type checker and the linter recognise some (but +not all) of these multiple forces as indeed linear. Mostly just enough to +support variable patterns. + +In summary: + +- Fields of data constructors defined with Haskell 98 syntax are always linear + (even if `-XLinearTypes` is off). This choice has been made to favour sharing + types between linearly typed Haskell and traditional Haskell. To avoid an + ecosystem split. +- When `-XLinearTypes` is off, GADT-syntax declaration can only use the regular + arrow `(->)`. However all the fields are linear. + + Note [Polymorphisation of linear fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The choice in Note [Data constructors are linear by default] has an impact on @@ -295,13 +339,13 @@ -- 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 +373,25 @@ -- 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 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -7,2176 +7,3132 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Arity and eta expansion -module GHC.Core.Opt.Arity - ( manifestArity, joinRhsArity, exprArity, typeArity - , exprEtaExpandArity, findRhsArity - , etaExpand, etaExpandAT - , exprBotStrictness_maybe - - -- ** ArityType - , ArityType(..), mkBotArityType, mkManifestArityType, expandableArityType - , arityTypeArity, maxWithArity, idArityType - - -- ** Join points - , etaExpandToJoinPoint, etaExpandToJoinPointRule - - -- ** Coercions and casts - , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg - , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo - ) -where - -import GHC.Prelude - -import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.DataCon -import GHC.Core.TyCon ( tyConArity ) -import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) -import GHC.Core.Predicate ( isDictTy, isCallStackPredTy ) -import GHC.Core.Multiplicity - --- We have two sorts of substitution: --- GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst --- Both have substTy, substCo Hence need for qualification -import GHC.Core.Subst as Core -import GHC.Core.Type as Type -import GHC.Core.Coercion as Type - -import GHC.Types.Demand -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.Basic -import GHC.Types.Tickish - -import GHC.Builtin.Uniques -import GHC.Data.FastString -import GHC.Data.Pair - -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Trace -import GHC.Utils.Misc - -{- -************************************************************************ -* * - manifestArity and exprArity -* * -************************************************************************ - -exprArity is a cheap-and-cheerful version of exprEtaExpandArity. -It tells how many things the expression can be applied to before doing -any work. It doesn't look inside cases, lets, etc. The idea is that -exprEtaExpandArity will do the hard work, leaving something that's easy -for exprArity to grapple with. In particular, Simplify uses exprArity to -compute the ArityInfo for the Id. - -Originally I thought that it was enough just to look for top-level lambdas, but -it isn't. I've seen this - - foo = PrelBase.timesInt - -We want foo to get arity 2 even though the eta-expander will leave it -unchanged, in the expectation that it'll be inlined. But occasionally it -isn't, because foo is blacklisted (used in a rule). - -Similarly, see the ok_note check in exprEtaExpandArity. So - f = __inline_me (\x -> e) -won't be eta-expanded. - -And in any case it seems more robust to have exprArity be a bit more intelligent. -But note that (\x y z -> f x y z) -should have arity 3, regardless of f's arity. --} - -manifestArity :: CoreExpr -> Arity --- ^ manifestArity sees how many leading value lambdas there are, --- after looking through casts -manifestArity (Lam v e) | isId v = 1 + manifestArity e - | otherwise = manifestArity e -manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e -manifestArity (Cast e _) = manifestArity e -manifestArity _ = 0 - -joinRhsArity :: CoreExpr -> JoinArity --- Join points are supposed to have manifestly-visible --- lambdas at the top: no ticks, no casts, nothing --- Moreover, type lambdas count in JoinArity -joinRhsArity (Lam _ e) = 1 + joinRhsArity e -joinRhsArity _ = 0 - - ---------------- -exprArity :: CoreExpr -> Arity --- ^ An approximate, fast, version of 'exprEtaExpandArity' -exprArity e = go e - where - go (Var v) = idArity v - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = trim_arity (go e) (coercionRKind co) - -- See Note [exprArity invariant] - go (App e (Type _)) = go e - go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 - -- See Note [exprArity for applications] - -- NB: coercions count as a value argument - - go _ = 0 - - trim_arity :: Arity -> Type -> Arity - trim_arity arity ty = arity `min` length (typeArity ty) - ---------------- -typeArity :: Type -> [OneShotInfo] --- How many value arrows are visible in the type? --- We look through foralls, and newtypes --- See Note [exprArity invariant] -typeArity ty - = go initRecTc ty - where - go rec_nts ty - | Just (_, ty') <- splitForAllTyCoVar_maybe ty - = go rec_nts ty' - - | Just (_,arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res - - | Just (tc,tys) <- splitTyConApp_maybe ty - , Just (ty', _) <- instNewTyCon_maybe tc tys - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes and products] - -- in GHC.Core.TyCon --- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes --- -- See Note [Newtype classes and eta expansion] --- (no longer required) - = go rec_nts' ty' - -- Important to look through non-recursive newtypes, so that, eg - -- (f x) where f has arity 2, f :: Int -> IO () - -- Here we want to get arity 1 for the result! - -- - -- AND through a layer of recursive newtypes - -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - - | otherwise - = [] - ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType botStrictnessArityEnv e) of - Nothing -> Nothing - Just ar -> Just (ar, sig ar) - where - sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv - -{- -Note [exprArity invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariants: - - (1) If typeArity (exprType e) = n, - then manifestArity (etaExpand e n) = n - - That is, etaExpand can always expand as much as typeArity says - So the case analysis in etaExpand and in typeArity must match - - (2) exprArity e <= typeArity (exprType e) - - (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n - - That is, if exprArity says "the arity is n" then etaExpand really - can get "n" manifest lambdas to the top. - -Why is this important? Because - - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of - each top-level Id, and in - - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means - that the StgRhs has the right number of lambdas - -An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! - -Note [Newtype classes and eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NB: this nasty special case is no longer required, because - for newtype classes we don't use the class-op rule mechanism - at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 - --------- Old out of date comments, just for interest ----------- -We have to be careful when eta-expanding through newtypes. In general -it's a good idea, but annoyingly it interacts badly with the class-op -rule mechanism. Consider - - class C a where { op :: a -> a } - instance C b => C [b] where - op x = ... - -These translate to - - co :: forall a. (a->a) ~ C a - - $copList :: C b -> [b] -> [b] - $copList d x = ... - - $dfList :: C b -> C [b] - {-# DFunUnfolding = [$copList] #-} - $dfList d = $copList d |> co@[b] - -Now suppose we have: - - dCInt :: C Int - - blah :: [Int] -> [Int] - blah = op ($dfList dCInt) - -Now we want the built-in op/$dfList rule will fire to give - blah = $copList dCInt - -But with eta-expansion 'blah' might (and in #3772, which is -slightly more complicated, does) turn into - - blah = op (\eta. ($dfList dCInt |> sym co) eta) - -and now it is *much* harder for the op/$dfList rule to fire, because -exprIsConApp_maybe won't hold of the argument to op. I considered -trying to *make* it hold, but it's tricky and I gave up. - -The test simplCore/should_compile/T3722 is an excellent example. --------- End of old out of date comments, just for interest ----------- - - -Note [exprArity for applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to an application we check that the arg is trivial. - eg f (fac x) does not have arity 2, - even if f has arity 3! - -* We require that is trivial rather merely cheap. Suppose f has arity 2. - Then f (Just y) - has arity 0, because if we gave it arity 1 and then inlined f we'd get - let v = Just y in \w. - which has arity 0. And we try to maintain the invariant that we don't - have arity decreases. - -* The `max 0` is important! (\x y -> f x) has arity 2, even if f is - unknown, hence arity 0 - - -************************************************************************ -* * - Computing the "arity" of an expression -* * -************************************************************************ - -Note [Definition of arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "arity" of an expression 'e' is n if - applying 'e' to *fewer* than n *value* arguments - converges rapidly - -Or, to put it another way - - there is no work lost in duplicating the partial - application (e x1 .. x(n-1)) - -In the divergent case, no work is lost by duplicating because if the thing -is evaluated once, that's the end of the program. - -Or, to put it another way, in any context C - - C[ (\x1 .. xn. e x1 .. xn) ] - is as efficient as - C[ e ] - -It's all a bit more subtle than it looks: - -Note [One-shot lambdas] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider one-shot lambdas - let x = expensive in \y z -> E -We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. - -Note [Dealing with bottom] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Big Deal with computing arities is expressions like - - f = \x -> case x of - True -> \s -> e1 - False -> \s -> e2 - -This happens all the time when f :: Bool -> IO () -In this case we do eta-expand, in order to get that \s to the -top, and give f arity 2. - -This isn't really right in the presence of seq. Consider - (f bot) `seq` 1 - -This should diverge! But if we eta-expand, it won't. We ignore this -"problem" (unless -fpedantic-bottoms is on), because being scrupulous -would lose an important transformation for many programs. (See -#5587 for an example.) - -Consider also - f = \x -> error "foo" -Here, arity 1 is fine. But if it is - f = \x -> case x of - True -> error "foo" - False -> \y -> x+y -then we want to get arity 2. Technically, this isn't quite right, because - (f True) `seq` 1 -should diverge, but it'll converge if we eta-expand f. Nevertheless, we -do so; it improves some programs significantly, and increasing convergence -isn't a bad thing. Hence the ABot/ATop in ArityType. - -So these two transformations aren't always the Right Thing, and we -have several tickets reporting unexpected behaviour resulting from -this transformation. So we try to limit it as much as possible: - - (1) Do NOT move a lambda outside a known-bottom case expression - case undefined of { (a,b) -> \y -> e } - This showed up in #5557 - - (2) Do NOT move a lambda outside a case unless - (a) The scrutinee is ok-for-speculation, or - (b) more liberally: the scrutinee is cheap (e.g. a variable), and - -fpedantic-bottoms is not enforced (see #2915 for an example) - -Of course both (1) and (2) are readily defeated by disguising the bottoms. - -4. Note [Newtype arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Non-recursive newtypes are transparent, and should not get in the way. -We do (currently) eta-expand recursive newtypes too. So if we have, say - - newtype T = MkT ([T] -> Int) - -Suppose we have - e = coerce T f -where f has arity 1. Then: etaExpandArity e = 1; -that is, etaExpandArity looks through the coerce. - -When we eta-expand e to arity 1: eta_expand 1 e T -we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - - HOWEVER, note that if you use coerce bogusly you can ge - coerce Int negate - And since negate has arity 2, you might try to eta expand. But you can't - decompose Int to a function type. Hence the final case in eta_expand. - -Note [The state-transformer hack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - f = e -where e has arity n. Then, if we know from the context that f has -a usage type like - t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... -then we can expand the arity to m. This usage type says that -any application (x e1 .. en) will be applied to uniquely to (m-n) more args -Consider f = \x. let y = - in case x of - True -> foo - False -> \(s:RealWorld) -> e -where foo has arity 1. Then we want the state hack to -apply to foo too, so we can eta expand the case. - -Then we expect that if f is applied to one arg, it'll be applied to two -(that's the hack -- we don't really know, and sometimes it's false) -See also Id.isOneShotBndr. - -Note [State hack and bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a terrible idea to use the state hack on a bottoming function. -Here's what happens (#2861): - - f :: String -> IO T - f = \p. error "..." - -Eta-expand, using the state hack: - - f = \p. (\s. ((error "...") |> g1) s) |> g2 - g1 :: IO T ~ (S -> (S,T)) - g2 :: (S -> (S,T)) ~ IO T - -Extrude the g2 - - f' = \p. \s. ((error "...") |> g1) s - f = f' |> (String -> g2) - -Discard args for bottomming function - - f' = \p. \s. ((error "...") |> g1 |> g3 - g3 :: (S -> (S,T)) ~ (S,T) - -Extrude g1.g3 - - f'' = \p. \s. (error "...") - f' = f'' |> (String -> S -> g1.g3) - -And now we can repeat the whole loop. Aargh! The bug is in applying the -state hack to a function which then swallows the argument. - -This arose in another guise in #3959. Here we had - - catch# (throw exn >> return ()) - -Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. -After inlining (>>) we get - - catch# (\_. throw {IO ()} exn) - -We must *not* eta-expand to - - catch# (\_ _. throw {...} exn) - -because 'catch#' expects to get a (# _,_ #) after applying its argument to -a State#, not another function! - -In short, we use the state hack to allow us to push let inside a lambda, -but not to introduce a new lambda. - - -Note [ArityType] -~~~~~~~~~~~~~~~~ -ArityType is the result of a compositional analysis on expressions, -from which we can decide the real arity of the expression (extracted -with function exprEtaExpandArity). - -We use the following notation: - at ::= \o1..on.div - div ::= T | x | ⊥ - o ::= ? | 1 -And omit the \. if n = 0. Examples: - \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@ - ⊥ stands for @AT [] botDiv@ -See the 'Outputable' instance for more information. It's pretty simple. - -Here is what the fields mean. If an arbitrary expression 'f' has -ArityType 'at', then - - * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ - definitely diverges. Partial applications to fewer than n args may *or - may not* diverge. - - We allow ourselves to eta-expand bottoming functions, even - if doing so may lose some `seq` sharing, - let x = in \y. error (g x y) - ==> \y. let x = in error (g x y) - - * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f' - to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect - the one-shot-ness o1..on of its definition. - - NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have - arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves - cheap. - - * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely - really functions, or bottom, but *not* casts from a data type, in - at least one case branch. (If it's a function in one case branch but - an unsafe cast from a data type in another, the program is bogus.) - So eta expansion is dynamically ok; see Note [State hack and - bottoming functions], the part about catch# - -Example: - f = \x\y. let v = in - \s(one-shot) \t(one-shot). blah - 'f' has arity type \??11.T - The one-shot-ness means we can, in effect, push that - 'let' inside the \st. - - -Suppose f = \xy. x+y -Then f :: \??.T - f v :: \?.T - f :: T - - - -Note [Eta reduction in recursive RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following recursive function: - f = \x. ....g (\y. f y).... -The recursive call of f in its own RHS seems like a fine opportunity for -eta-reduction because f has arity 1. And often it is! - -Alas, that is unsound in general if the eta-reduction happens in a tail context. -Making the arity visible in the RHS allows us to eta-reduce - f = \x -> f x -to - f = f -which means we optimise terminating programs like (f `seq` ()) into -non-terminating ones. Nor is this problem just for tail calls. Consider - f = id (\x -> f x) -where we have (for some reason) not yet inlined `id`. We must not eta-reduce to - f = id f -because that will then simplify to `f = f` as before. - -An immediate idea might be to look at whether the called function is a local -loopbreaker and refrain from eta-expanding. But that doesn't work for mutually -recursive function like in #21652: - f = g - g* x = f x -Here, g* is the loopbreaker but f isn't. - -What can we do? - -Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when - entering the let body. - Has the disadvantage that other transformations which make use of arity - (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. - Plus it requires non-trivial refactorings to both the simple optimiser (in - the way `subst_opt_bndr` is used) as well as the Simplifier (in the way - `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's - substitution twice in the process. A very complicated stop-gap. - -Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are - the ones we should not eta-reduce. All call-site must maintain this set. - Example: - rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... - ; f2 = ...f1... } - when eta-reducing those inner lambdas, we need to know that we are in the - rec group for {f1, f2, g}. - This is very much like the solution in Note [Speculative evaluation] in - GHC.CoreToStg.Prep. - It is a bit tiresome to maintain this info, because it means another field - in SimplEnv and SimpleOptEnv. - -We implement Fix (2) because of it isn't as complicated to maintain as (1). -Plus, it is the correct fix to begin with. After all, the arity is correct, -but doing the transformation isn't. The moving parts are: - * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders - * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` - * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` -The situation is very similar to Note [Speculative evaluation] which has the -same fix. - --} - - --- | The analysis lattice of arity analysis. It is isomorphic to --- --- @ --- data ArityType' --- = AEnd Divergence --- | ALam OneShotInfo ArityType' --- @ --- --- Which is easier to display the Hasse diagram for: --- --- @ --- ALam OneShotLam at --- | --- AEnd topDiv --- | --- ALam NoOneShotInfo at --- | --- AEnd exnDiv --- | --- AEnd botDiv --- @ --- --- where the @at@ fields of @ALam@ are inductively subject to the same order. --- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. --- --- Why the strange Top element? --- See Note [Combining case branches: optimistic one-shot-ness] --- --- We rely on this lattice structure for fixed-point iteration in --- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. -data ArityType - = AT ![OneShotInfo] !Divergence - -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@ - -- times, provided use sites respect the 'OneShotInfo's in @oss@. - -- A 'OneShotLam' annotation can come from two sources: - -- * The user annotated a lambda as one-shot with 'GHC.Exts.oneShot' - -- * It's from a lambda binder of a type affected by `-fstate-hack`. - -- See 'idStateHackOneShotInfo'. - -- In both cases, 'OneShotLam' should win over 'NoOneShotInfo', see - -- Note [Combining case branches]. - -- - -- If @div@ is dead-ending ('isDeadEndDiv'), then application to - -- @length os@ arguments will surely diverge, similar to the situation - -- with 'DmdType'. - deriving Eq - --- | This is the BNF of the generated output: --- --- @ --- @ --- --- We format --- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and --- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. --- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. --- If the one-shot info is empty, we omit the leading @\.@. -instance Outputable ArityType where - ppr (AT oss div) - | null oss = pp_div div - | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div - where - pp_div Diverges = char '⊥' - pp_div ExnOrDiv = char 'x' - pp_div Dunno = char 'T' - pp_os OneShotLam = char '1' - pp_os NoOneShotInfo = char '?' - -mkBotArityType :: [OneShotInfo] -> ArityType -mkBotArityType oss = AT oss botDiv - -botArityType :: ArityType -botArityType = mkBotArityType [] - -mkManifestArityType :: [Var] -> CoreExpr -> ArityType -mkManifestArityType bndrs body - = AT oss div - where - oss = [idOneShotInfo bndr | bndr <- bndrs, isId bndr] - div | exprIsDeadEnd body = botDiv - | otherwise = topDiv - -topArityType :: ArityType -topArityType = AT [] topDiv - --- | The number of value args for the arity type -arityTypeArity :: ArityType -> Arity -arityTypeArity (AT oss _) = length oss - --- | True <=> eta-expansion will add at least one lambda -expandableArityType :: ArityType -> Bool -expandableArityType at = arityTypeArity at > 0 - --- | See Note [Dead ends] in "GHC.Types.Demand". --- Bottom implies a dead end. -isDeadEndArityType :: ArityType -> Bool -isDeadEndArityType (AT _ div) = isDeadEndDiv div - --- | Expand a non-bottoming arity type so that it has at least the given arity. -maxWithArity :: ArityType -> Arity -> ArityType -maxWithArity at@(AT oss div) !ar - | isDeadEndArityType at = at - | oss `lengthAtLeast` ar = at - | otherwise = AT (take ar $ oss ++ repeat NoOneShotInfo) div - --- | Trim an arity type so that it has at most the given arity. --- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in --- 'ABot'. -minWithArity :: ArityType -> Arity -> ArityType -minWithArity at@(AT oss _) ar - | oss `lengthAtMost` ar = at - | otherwise = AT (take ar oss) topDiv - -takeWhileOneShot :: ArityType -> ArityType -takeWhileOneShot (AT oss div) - | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv - | otherwise = AT (takeWhile isOneShotInfo oss) div - --- | The Arity returned is the number of value args the --- expression can be applied to without doing much work -exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -exprEtaExpandArity dflags e = arityType (findRhsArityEnv dflags) e - -getBotArity :: ArityType -> Maybe Arity --- Arity of a divergent function -getBotArity (AT oss div) - | isDeadEndDiv div = Just $ length oss - | otherwise = Nothing - ----------------------- -findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType --- This implements the fixpoint loop for arity analysis --- See Note [Arity analysis] --- If findRhsArity e = (n, is_bot) then --- (a) any application of e to (\x1..xn. e x1 .. xn) --- (b) if is_bot=True, then e applied to n args is guaranteed bottom -findRhsArity dflags bndr rhs old_arity - = go 0 botArityType - -- We always do one step, but usually that produces a result equal to - -- old_arity, and then we stop right away, because old_arity is assumed - -- to be sound. In other words, arities should never decrease. - -- Result: the common case is that there is just one iteration - where - go :: Int -> ArityType -> ArityType - go !n cur_at@(AT oss div) - | not (isDeadEndDiv div) -- the "stop right away" case - , length oss <= old_arity = cur_at -- from above - | next_at == cur_at = cur_at - | otherwise = - -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] - warnPprTrace (debugIsOn && n > 2) - "Exciting arity" - (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ - go (n+1) next_at - where - next_at = step cur_at - - step :: ArityType -> ArityType - step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $ - arityType env rhs - where - env = extendSigEnv (findRhsArityEnv dflags) bndr at - - -{- -Note [Arity analysis] -~~~~~~~~~~~~~~~~~~~~~ -The motivating example for arity analysis is this: - - f = \x. let g = f (x+1) - in \y. ...g... - -What arity does f have? Really it should have arity 2, but a naive -look at the RHS won't see that. You need a fixpoint analysis which -says it has arity "infinity" the first time round. - -This example happens a lot; it first showed up in Andy Gill's thesis, -fifteen years ago! It also shows up in the code for 'rnf' on lists -in #4138. - -We do the necessary, quite simple fixed-point iteration in 'findRhsArity', -which assumes for a single binding 'ABot' on the first run and iterates -until it finds a stable arity type. Two wrinkles - -* We often have to ask (see the Case or Let case of 'arityType') whether some - expression is cheap. In the case of an application, that depends on the arity - of the application head! That's why we have our own version of 'exprIsCheap', - 'myExprIsCheap', that will integrate the optimistic arity types we have on - f and g into the cheapness check. - -* Consider this (#18793) - - go = \ds. case ds of - [] -> id - (x:ys) -> let acc = go ys in - case blah of - True -> acc - False -> \ x1 -> acc (negate x1) - - We must propagate go's optimistically large arity to @acc@, so that the - tail call to @acc@ in the True branch has sufficient arity. This is done - by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case - of 'arityType'. - -Note [Exciting arity] -~~~~~~~~~~~~~~~~~~~~~ -The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost -all cases. To get notified of cases where we need an usual number of iterations, -we emit a warning in debug mode, so that we can investigate and make sure that -we really can't do better. It's a gross hack, but catches real bugs (#18870). - -Now, which number is "unusual"? We pick n > 2. Here's a pretty common and -expected example that takes two iterations and would ruin the specificity -of the warning (from T18937): - - f :: [Int] -> Int -> Int - f [] = id - f (x:xs) = let y = sum [0..x] - in \z -> f xs (y + z) - -Fixed-point iteration starts with arity type ⊥ for f. After the first -iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally -'floatIn' the let-binding (see its bottom case). After the second iteration, -we get arity type \?.T, e.g. arity 1, because now we are no longer allowed -to floatIn the non-cheap let-binding. Which is all perfectly benign, but -means we do two iterations (well, actually 3 'step's to detect we are stable) -and don't want to emit the warning. - -Note [Eta expanding through dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the experimental -fdicts-cheap flag is on, we eta-expand through -dictionary bindings. This improves arities. Thereby, it also -means that full laziness is less prone to floating out the -application of a function to its dictionary arguments, which -can thereby lose opportunities for fusion. Example: - foo :: Ord a => a -> ... - foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... - -- So foo has arity 1 - - f = \x. foo dInt $ bar x - -The (foo DInt) is floated out, and makes ineffective a RULE - foo (bar x) = ... - -One could go further and make exprIsCheap reply True to any -dictionary-typed expression, but that's more work. --} - -arityLam :: Id -> ArityType -> ArityType -arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div - -floatIn :: Bool -> ArityType -> ArityType --- We have something like (let x = E in b), --- where b has the given arity type. -floatIn cheap at - | isDeadEndArityType at || cheap = at - -- If E is not cheap, keep arity only for one-shots - | otherwise = takeWhileOneShot at - -arityApp :: ArityType -> Bool -> ArityType - --- Processing (fun arg) where at is the ArityType of fun, --- Knock off an argument and behave like 'let' -arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div) -arityApp at _ = at - --- | Least upper bound in the 'ArityType' lattice. --- See the haddocks on 'ArityType' for the lattice. --- --- Used for branches of a @case@. -andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType -andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) - | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) - = AT ((lam1 `and_lam` lam2) : lams') div' - where - (os1) `and_lam` (os2) - = ( os1 `bestOneShot` os2) - -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] - -andArityType env (AT [] div1) at2 = andWithTail env div1 at2 -andArityType env at1 (AT [] div2) = andWithTail env div2 at1 - -andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType -andWithTail env div1 at2 - | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } - = at2 -- Note [ABot branches: max arity wins] - - | pedanticBottoms env -- Note [Combining case branches: andWithTail] - = AT [] topDiv - - | otherwise -- case x of { T -> plusInt ; F -> \y.e } - = takeWhileOneShot at2 -- We know div1 = topDiv - -- See Note [Combining case branches: andWithTail] - - -{- Note [ABot branches: max arity wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case x of - True -> \x. error "urk" - False -> \xy. error "urk2" - -Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". -So we need \??.⊥ for the whole thing, the /max/ of both arities. - -Note [Combining case branches: optimistic one-shot-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When combining the ArityTypes for two case branches (with andArityType) -and both ArityTypes have ATLamInfo, then we just combine their -expensive-ness and one-shot info. The tricky point is when we have - case x of True -> \x{one-shot). blah1 - Fale -> \y. blah2 - -Since one-shot-ness is about the /consumer/ not the /producer/, we -optimistically assume that if either branch is one-shot, we combine -the best of the two branches, on the (slightly dodgy) basis that if we -know one branch is one-shot, then they all must be. Surprisingly, -this means that the one-shot arity type is effectively the top element -of the lattice. - -Hence the call to `bestOneShot` in `andArityType`. - -Note [Combining case branches: andWithTail] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When combining the ArityTypes for two case branches (with andArityType) -and one side or the other has run out of ATLamInfo; then we get -into `andWithTail`. - -* If one branch is guaranteed bottom (isDeadEndDiv), we just take - the other; see Note [ABot branches: max arity wins] - -* Otherwise, if pedantic-bottoms is on, we just have to return - AT [] topDiv. E.g. if we have - f x z = case x of True -> \y. blah - False -> z - then we can't eta-expand, because that would change the behaviour - of (f False bottom(). - -* But if pedantic-bottoms is not on, we allow ourselves to push - `z` under a lambda (much as we allow ourselves to put the `case x` - under a lambda). However we know nothing about the expensiveness - or one-shot-ness of `z`, so we'd better assume it looks like - (Expensive, NoOneShotInfo) all the way. Remembering - Note [Combining case branches: optimistic one-shot-ness], - we just add work to ever ATLamInfo, keeping the one-shot-ness. - -Here's an example: - go = \x. let z = go e0 - go2 = \x. case x of - True -> z - False -> \s(one-shot). e1 - in go2 x -We *really* want to respect the one-shot annotation provided by the -user and eta-expand go and go2. -When combining the branches of the case we have - T `andAT` \1.T -and we want to get \1.T. -But if the inner lambda wasn't one-shot (\?.T) we don't want to do this. -(We need a usage analysis to justify that.) - -Unless we can conclude that **all** branches are safe to eta-expand then we -must pessimisticaly conclude that we can't eta-expand. See #21694 for where this -went wrong. -We can do better in the long run, but for the 9.4/9.2 branches we choose to simply -ignore oneshot annotations for the time being. - - -Note [Arity trimming] -~~~~~~~~~~~~~~~~~~~~~ -Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and -F is some type family. - -Because of Note [exprArity invariant], item (2), we must return with arity at -most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of -calling arityType on (\x y. blah). Failing to do so, and hence breaking the -exprArity invariant, led to #5441. - -How to trim? If we end in topDiv, it's easy. But we must take great care with -dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), -we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that -claims that ((\x y. error "urk") |> co) diverges when given one argument, -which it absolutely does not. And Bad Things happen if we think something -returns bottom when it doesn't (#16066). - -So, if we need to trim a dead-ending arity type, switch (conservatively) to -topDiv. - -Historical note: long ago, we unconditionally switched to topDiv when we -encountered a cast, but that is far too conservative: see #5475 - -Note [Eta expanding through CallStacks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just as it's good to eta-expand through dictionaries, so it is good to -do so through CallStacks. #20103 is a case in point, where we got - foo :: HasCallStack => Int -> Int - foo = \(d::CallStack). let d2 = pushCallStack blah d in - \(x:Int). blah - -We really want to eta-expand this! #20103 is quite convincing! -We do this regardless of -fdicts-cheap; it's not really a dictionary. --} - ---------------------------- - --- | Each of the entry-points of the analyser ('arityType') has different --- requirements. The entry-points are --- --- 1. 'exprBotStrictness_maybe' --- 2. 'exprEtaExpandArity' --- 3. 'findRhsArity' --- --- For each of the entry-points, there is a separate mode that governs --- --- 1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'. --- 2. Whether we store arity signatures for non-recursive let-bindings, --- accessed in 'extendSigEnv'/'lookupSigEnv'. --- See Note [Arity analysis] why that's important. --- 3. Which expressions we consider cheap to float inside a lambda, --- in 'myExprIsCheap'. -data AnalysisMode - = BotStrictness - -- ^ Used during 'exprBotStrictness_maybe'. - | EtaExpandArity { am_ped_bot :: !Bool - , am_dicts_cheap :: !Bool } - -- ^ Used for finding an expression's eta-expanding arity quickly, without - -- fixed-point iteration ('exprEtaExpandArity'). - | FindRhsArity { am_ped_bot :: !Bool - , am_dicts_cheap :: !Bool - , am_sigs :: !(IdEnv ArityType) } - -- ^ Used for regular, fixed-point arity analysis ('findRhsArity'). - -- See Note [Arity analysis] for details about fixed-point iteration. - -- INVARIANT: Disjoint with 'ae_joins'. - -data ArityEnv - = AE - { ae_mode :: !AnalysisMode - -- ^ The analysis mode. See 'AnalysisMode'. - } - --- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms --- and no application is ever considered cheap. -botStrictnessArityEnv :: ArityEnv -botStrictnessArityEnv = AE { ae_mode = BotStrictness } - -{- --- | The @ArityEnv@ used by 'exprEtaExpandArity'. -etaExpandArityEnv :: DynFlags -> ArityEnv -etaExpandArityEnv dflags - = AE { ae_mode = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags - , am_dicts_cheap = gopt Opt_DictsCheap dflags } - , ae_joins = emptyVarSet } --} - --- | The @ArityEnv@ used by 'findRhsArity'. -findRhsArityEnv :: DynFlags -> ArityEnv -findRhsArityEnv dflags - = AE { ae_mode = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags - , am_dicts_cheap = gopt Opt_DictsCheap dflags - , am_sigs = emptyVarEnv } - } - -isFindRhsArity :: ArityEnv -> Bool -isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True -isFindRhsArity _ = False - --- First some internal functions in snake_case for deleting in certain VarEnvs --- of the ArityType. Don't call these; call delInScope* instead! - -modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv -modifySigEnv f env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } = - env { ae_mode = am { am_sigs = f sigs } } -modifySigEnv _ env = env -{-# INLINE modifySigEnv #-} - -del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! -del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id) -{-# INLINE del_sig_env #-} - -del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! -del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) -{-# INLINE del_sig_env_list #-} - --- end of internal deletion functions - -extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv -extendSigEnv env id ar_ty - = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env - -delInScope :: ArityEnv -> Id -> ArityEnv -delInScope env id = del_sig_env id env - -delInScopeList :: ArityEnv -> [Id] -> ArityEnv -delInScopeList env ids = del_sig_env_list ids env - -lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType -lookupSigEnv AE{ ae_mode = mode } id = case mode of - BotStrictness -> Nothing - EtaExpandArity{} -> Nothing - FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id - --- | Whether the analysis should be pedantic about bottoms. --- 'exprBotStrictness_maybe' always is. -pedanticBottoms :: ArityEnv -> Bool -pedanticBottoms AE{ ae_mode = mode } = case mode of - BotStrictness -> True - EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot - FindRhsArity{ am_ped_bot = ped_bot } -> ped_bot - --- | A version of 'exprIsCheap' that considers results from arity analysis --- and optionally the expression's type. --- Under 'exprBotStrictness_maybe', no expressions are cheap. -myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool -myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of - BotStrictness -> False - _ -> cheap_dict || cheap_fun e - where - cheap_dict = case mb_ty of - Nothing -> False - Just ty -> (am_dicts_cheap mode && isDictTy ty) - || isCallStackPredTy ty - -- See Note [Eta expanding through dictionaries] - -- See Note [Eta expanding through CallStacks] - - cheap_fun e = case mode of -#if __GLASGOW_HASKELL__ <= 900 - BotStrictness -> panic "impossible" -#endif - EtaExpandArity{} -> exprIsCheap e - FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e - --- | A version of 'isCheapApp' that considers results from arity analysis. --- See Note [Arity analysis] for what's in the signature environment and why --- it's important. -myIsCheapApp :: IdEnv ArityType -> CheapAppFun -myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of - -- Nothing means not a local function, fall back to regular - -- 'GHC.Core.Utils.isCheapApp' - Nothing -> isCheapApp fn n_val_args - - -- `Just at` means local function with `at` as current SafeArityType. - -- NB the SafeArityType bit: that means we can ignore the cost flags - -- in 'lams', and just consider the length - -- Roughly approximate what 'isCheapApp' is doing. - Just (AT oss div) - | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils - | n_val_args < length oss -> True -- Essentially isWorkFreeApp - | otherwise -> False - ----------------- -arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType --- Precondition: all the free join points of the expression --- are bound by the ArityEnv --- See Note [No free join points in arityType] - -arityType env (Cast e co) - = minWithArity (arityType env e) co_arity -- See Note [Arity trimming] - where - co_arity = length (typeArity (coercionRKind co)) - -- See Note [exprArity invariant] (2); must be true of - -- arityType too, since that is how we compute the arity - -- of variables, and they in turn affect result of exprArity - -- #5441 is a nice demo - -arityType env (Var v) - | Just at <- lookupSigEnv env v -- Local binding - = at - | otherwise - = assertPpr (not (isFindRhsArity env && isJoinId v)) (ppr v) $ - -- All join-point should be in the ae_sigs - -- See Note [No free join points in arityType] - idArityType v - - -- Lambdas; increase arity -arityType env (Lam x e) - | isId x = arityLam x (arityType env' e) - | otherwise = arityType env' e - where - env' = delInScope env x - - -- Applications; decrease arity, except for types -arityType env (App fun (Type _)) - = arityType env fun -arityType env (App fun arg ) - = arityApp (arityType env fun) (myExprIsCheap env arg Nothing) - - -- Case/Let; keep arity if either the expression is cheap - -- or it's a 1-shot lambda - -- The former is not really right for Haskell - -- f x = case x of { (a,b) -> \y. e } - -- ===> - -- f x y = case x of { (a,b) -> e } - -- The difference is observable using 'seq' - -- -arityType env (Case scrut bndr _ alts) - | exprIsDeadEnd scrut || null alts - = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] - | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] - , myExprIsCheap env scrut (Just (idType bndr)) - = alts_type - | exprOkForSpeculation scrut - = alts_type - - | otherwise -- In the remaining cases we may not push - = takeWhileOneShot alts_type -- evaluation of the scrutinee in - where - env' = delInScope env bndr - arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs - alts_type = foldr1 (andArityType env) (map arity_type_alt alts) - -arityType env (Let (NonRec b r) e) - = -- See Note [arityType for let-bindings] - floatIn cheap_rhs (arityType env' e) - where - cheap_rhs = myExprIsCheap env r (Just (idType b)) - env' = extendSigEnv env b (arityType env r) - -arityType env (Let (Rec prs) e) - = floatIn (all is_cheap prs) (arityType env' e) - where - is_cheap (b,e) = myExprIsCheap env' e (Just (idType b)) - env' = foldl extend_rec env prs - extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv - extend_rec env (b,e) = extendSigEnv env b $ - mkManifestArityType bndrs body - where - (bndrs, body) = collectBinders e - -- We can't call arityType on the RHS, because it might mention - -- join points bound in this very letrec, and we don't want to - -- do a fixpoint calculation here. So we make do with the - -- manifest arity - -arityType env (Tick t e) - | not (tickishIsCode t) = arityType env e - -arityType _ _ = topArityType - - -{- Note [No free join points in arityType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we call arityType on this expression (EX1) - \x . case x of True -> \y. e - False -> $j 3 -where $j is a join point. It really makes no sense to talk of the arity -of this expression, because it has a free join point. In particular, we -can't eta-expand the expression because we'd have do the same thing to the -binding of $j, and we can't see that binding. - -If we had (EX2) - \x. join $j y = blah - case x of True -> \y. e - False -> $j 3 -then it would make perfect sense: we can determine $j's ArityType, and -propagate it to the usage site as usual. - -But how can we get (EX1)? It doesn't make much sense, because $j can't -be a join point under the \x anyway. So we make it a precondition of -arityType that the argument has no free join-point Ids. (This is checked -with an assesrt in the Var case of arityType.) - -BUT the invariant risks being invalidated by one very narrow special case: runRW# - join $j y = blah - runRW# (\s. case x of True -> \y. e - False -> $j x) - -We have special magic in OccurAnal, and Simplify to allow continuations to -move into the body of a runRW# call. - -So we are careful never to attempt to eta-expand the (\s.blah) in the -argument to runRW#, at least not when there is a literal lambda there, -so that OccurAnal has seen it and allowed join points bound outside. -See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. - -Note [arityType for let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For non-recursive let-bindings, we just get the arityType of the RHS, -and extend the environment. That works nicely for things like this -(#18793): - go = \ ds. case ds_a2CF of { - [] -> id - : y ys -> case y of { GHC.Types.I# x -> - let acc = go ys in - case x ># 42# of { - __DEFAULT -> acc - 1# -> \x1. acc (negate x2) - -Here we want to get a good arity for `acc`, based on the ArityType -of `go`. - -All this is particularly important for join points. Consider this (#18328) - - f x = join j y = case y of - True -> \a. blah - False -> \b. blah - in case x of - A -> j True - B -> \c. blah - C -> j False - -and suppose the join point is too big to inline. Now, what is the -arity of f? If we inlined the join point, we'd definitely say "arity -2" because we are prepared to push case-scrutinisation inside a -lambda. It's important that we extend the envt with j's ArityType, -so that we can use that information in the A/C branch of the case. - -For /recursive/ bindings it's more difficult, to call arityType, -because we don't have an ArityType to put in the envt for the -recursively bound Ids. So for non-join-point bindings we satisfy -ourselves with mkManifestArityType. Typically we'll have eta-expanded -the binding (based on an earlier fixpoint calculation in -findRhsArity), so the manifest arity is good. - -But for /recursive join points/ things are not so good. -See Note [Arity type for recursive join bindings] - -See Note [Arity type for recursive join bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = joinrec j 0 = \ a b c -> (a,x,b) - j n = j (n-1) - in j 20 - -Obviously `f` should get arity 4. But the manifest arity of `j` -is 1. Remember, we don't eta-expand join points; see -GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points]. -And the ArityInfo on `j` will be just 1 too; see GHC.Core -Note [Invariants on join points], item (2b). So using -Note [ArityType for let-bindings] won't work well. - -We could do a fixpoint iteration, but that's a heavy hammer -to use in arityType. So we take advantage of it being a join -point: - -* Extend the ArityEnv to bind each of the recursive binders - (all join points) to `botArityType`. This means that any - jump to the join point will return botArityType, which is - unit for `andArityType`: - botAritType `andArityType` at = at - So it's almost as if those "jump" branches didn't exist. - -* In this extended env, find the ArityType of each of the RHS, after - stripping off the join-point binders. - -* Use andArityType to combine all these RHS ArityTypes. - -* Find the ArityType of the body, also in this strange extended - environment - -* And combine that into the result with andArityType. - -In our example, the jump (j 20) will yield Bot, as will the jump -(j (n-1)). We'll 'and' those the ArityType of (\abc. blah). Good! - -In effect we are treating the RHSs as alternative bodies (like -in a case), and ignoring all jumps. In this way we don't need -to take a fixpoint. Tricky! - -NB: we treat /non-recursive/ join points in the same way, but -actually it works fine to treat them uniformly with normal -let-bindings, and that takes less code. --} - -idArityType :: Id -> ArityType -idArityType v - | strict_sig <- idDmdSig v - , not $ isNopSig strict_sig - , (ds, div) <- splitDmdSig strict_sig - , let arity = length ds - -- Every strictness signature admits an arity signature! - = AT (take arity one_shots) div - | otherwise - = AT (take (idArity v) one_shots) topDiv - where - one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeArity (idType v) - -{- -%************************************************************************ -%* * - The main eta-expander -%* * -%************************************************************************ - -We go for: - f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym - (n >= 0) - -where (in both cases) - - * The xi can include type variables - - * The yi are all value variables - - * N is a NORMAL FORM (i.e. no redexes anywhere) - wanting a suitable number of extra args. - -The biggest reason for doing this is for cases like - - f = \x -> case x of - True -> \y -> e1 - False -> \y -> e2 - -Here we want to get the lambdas together. A good example is the nofib -program fibheaps, which gets 25% more allocation if you don't do this -eta-expansion. - -We may have to sandwich some coerces between the lambdas -to make the types work. exprEtaExpandArity looks through coerces -when computing arity; and etaExpand adds the coerces as necessary when -actually computing the expansion. - -Note [No crap in eta-expanded code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The eta expander is careful not to introduce "crap". In particular, -given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it -returns a CoreExpr satisfying the same invariant. See Note [Eta -expansion and the CorePrep invariants] in CorePrep. - -This means the eta-expander has to do a bit of on-the-fly -simplification but it's not too hard. The alternative, of relying on -a subsequent clean-up phase of the Simplifier to de-crapify the result, -means you can't really use it in CorePrep, which is painful. - -Note [Eta expansion for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The no-crap rule is very tiresome to guarantee when -we have join points. Consider eta-expanding - let j :: Int -> Int -> Bool - j x = e - in b - -The simple way is - \(y::Int). (let j x = e in b) y - -The no-crap way is - \(y::Int). let j' :: Int -> Bool - j' x = e y - in b[j'/j] y -where I have written to stress that j's type has -changed. Note that (of course!) we have to push the application -inside the RHS of the join as well as into the body. AND if j -has an unfolding we have to push it into there too. AND j might -be recursive... - -So for now I'm abandoning the no-crap rule in this case. I think -that for the use in CorePrep it really doesn't matter; and if -it does, then CoreToStg.myCollectArgs will fall over. - -(Moreover, I think that casts can make the no-crap rule fail too.) - -Note [Eta expansion and SCCs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that SCCs are not treated specially by etaExpand. If we have - etaExpand 2 (\x -> scc "foo" e) - = (\xy -> (scc "foo" e) y) -So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -Note [Eta expansion and source notes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep puts floatable ticks outside of value applications, but not -type applications. As a result we might be trying to eta-expand an -expression like - - (src<...> v) @a - -which we want to lead to code like - - \x -> src<...> v @a x - -This means that we need to look through type applications and be ready -to re-add floats on the top. - -Note [Eta expansion with ArityType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The etaExpandAT function takes an ArityType (not just an Arity) to -guide eta-expansion. Why? Because we want to preserve one-shot info. -Consider - foo = \x. case x of - True -> (\s{os}. blah) |> co - False -> wubble -We'll get an ArityType for foo of \?1.T. - -Then we want to eta-expand to - foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co - -That 'eta' binder is fresh, and we really want it to have the -one-shot flag from the inner \s{os}. By expanding with the -ArityType gotten from analysing the RHS, we achieve this neatly. - -This makes a big difference to the one-shot monad trick; -see Note [The one-shot state monad trick] in GHC.Utils.Monad. --} - --- | @etaExpand n e@ returns an expression with --- the same meaning as @e@, but with arity @n@. --- --- Given: --- --- > e' = etaExpand n e --- --- We should have that: --- --- > ty = exprType e = exprType e' - -etaExpand :: Arity -> CoreExpr -> CoreExpr -etaExpand n orig_expr - = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr - where - in_scope = {-#SCC "eta_expand:in-scopeX" #-} - mkInScopeSet (exprFreeVars orig_expr) - -etaExpandAT :: InScopeSet -> ArityType -> CoreExpr -> CoreExpr --- See Note [Eta expansion with ArityType] --- --- We pass in the InScopeSet from the simplifier to avoid recomputing --- it here, which can be jolly expensive if the casts are big --- In #18223 it took 10% of compile time just to do the exprFreeVars! -etaExpandAT in_scope (AT oss _) orig_expr - = eta_expand in_scope oss orig_expr - --- etaExpand arity e = res --- Then 'res' has at least 'arity' lambdas at the top --- possibly with a cast wrapped around the outside --- See Note [Eta expansion with ArityType] --- --- etaExpand deals with for-alls. For example: --- etaExpand 1 E --- where E :: forall a. a -> a --- would return --- (/\b. \y::a -> E b y) - -eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr -eta_expand in_scope one_shots (Cast expr co) - = Cast (eta_expand in_scope one_shots expr) co - -eta_expand in_scope one_shots orig_expr - = go in_scope one_shots [] orig_expr - where - -- Strip off existing lambdas and casts before handing off to mkEtaWW - -- This is mainly to avoid spending time cloning binders and substituting - -- when there is actually nothing to do. It's slightly awkward to deal - -- with casts here, apart from the topmost one, and they are rare, so - -- if we find one we just hand off to mkEtaWW anyway - -- Note [Eta expansion and SCCs] - go _ [] _ _ = orig_expr -- Already has the specified arity; no-op - - go in_scope oss@(_:oss1) vs (Lam v body) - | isTyVar v = go (in_scope `extendInScopeSet` v) oss (v:vs) body - | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body - - go in_scope oss rev_vs expr - = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ - retick $ - etaInfoAbs top_eis $ - etaInfoApp in_scope' sexpr eis - where - (in_scope', eis@(EI eta_bndrs mco)) - = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) - top_bndrs = reverse rev_vs - top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) - - -- Find ticks behind type apps. - -- See Note [Eta expansion and source notes] - -- I don't really understand this code SLPJ May 21 - (expr', args) = collectArgs expr - (ticks, expr'') = stripTicksTop tickishFloatable expr' - sexpr = mkApps expr'' args - retick expr = foldr mkTick expr ticks - -{- ********************************************************************* -* * - The EtaInfo mechanism - mkEtaWW, etaInfoAbs, etaInfoApp -* * -********************************************************************* -} - -{- Note [The EtaInfo mechanism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (e :: ty) and we want to eta-expand it to arity N. -This what eta_expand does. We do it in two steps: - -1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes - the shape of the expansion necessary to expand to arity N. - -2. Build the term - \ v1..vn. e v1 .. vn - where those abstractions and applications are described by - the same EtaInfo. Specifically we build the term - - etaInfoAbs etas (etaInfoApp in_scope e etas) - - where etas :: EtaInfo - etaInfoAbs builds the lambdas - etaInfoApp builds the applictions - - Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp - -To a first approximation EtaInfo is just [Var]. But -casts complicate the question. If we have - newtype N a = MkN (S -> a) - axN :: N a ~ S -> a -and - e :: N (N Int) -then the eta-expansion should look like - (\(x::S) (y::S) -> e |> co x y) |> sym co -where - co :: N (N Int) ~ S -> S -> Int - co = axN @(N Int) ; (S -> axN @Int) - -We want to get one cast, at the top, to account for all those -nested newtypes. This is expressed by the EtaInfo type: - - data EtaInfo = EI [Var] MCoercionR - -Note [Check for reflexive casts in eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out that the casts created by teh above mechanism are often Refl. -When casts are very deeply nested (as happens in #18223), the repetition -of types can make the overall term very large. So there is a big -payoff in cancelling out casts aggressively wherever possible. -(See also Note [No crap in eta-expanded code].) - -This matters particularly in etaInfoApp, where we -* Do beta-reduction on the fly -* Use getArg_maybe to get a cast out of the way, - so that we can do beta reduction -Together this makes a big difference. Consider when e is - case x of - True -> (\x -> e1) |> c1 - False -> (\p -> e2) |> c2 - -When we eta-expand this to arity 1, say, etaInfoAbs will wrap -a (\eta) around the outside and use etaInfoApp to apply each -alternative to 'eta'. We want to beta-reduce all that junk -away. - -#18223 was a dramatic example in which the intermediate term was -grotesquely huge, even though the next Simplifier iteration squashed -it. Better to kill it at birth. - -The crucial spots in etaInfoApp are: -* `checkReflexiveMCo` in the (Cast e co) case of `go` -* `checkReflexiveMCo` in `pushCoArg` -* Less important: checkReflexiveMCo in the final case of `go` -Collectively these make a factor-of-5 difference to the total -allocation of T18223, so take care if you change this stuff! - -Example: - newtype N = MkN (Y->Z) - f :: X -> N - f = \(x::X). ((\(y::Y). blah) |> fco) - -where fco :: (Y->Z) ~ N - -mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co - where - eta_co :: (X->N) ~ (X->Y->Z) - eta_co = ( -> nco) - nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe - -Now, when we push that eta_co inward in etaInfoApp: -* In the (Cast e co) case, the 'fco' and 'nco' will meet, and - should cancel. -* When we meet the (\y.e) we want no cast on the y. - --} - --------------- -data EtaInfo = EI [Var] MCoercionR - --- (EI bs co) describes a particular eta-expansion, as follows: --- Abstraction: (\b1 b2 .. bn. []) |> sym co --- Application: ([] |> co) b1 b2 .. bn --- --- e :: T co :: T ~ (t1 -> t2 -> .. -> tn -> tr) --- e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co - -instance Outputable EtaInfo where - ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) - - -etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr --- (etaInfoApp s e (EI bs mco) returns something equivalent to --- ((substExpr s e) |> mco b1 .. bn) --- See Note [The EtaInfo mechanism] --- --- NB: With very deeply nested casts, this function can be expensive --- In T18223, this function alone costs 15% of allocation, all --- spent in the calls to substExprSC and substBindSC - -etaInfoApp in_scope expr eis - = go (mkEmptySubst in_scope) expr eis - where - go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr - -- 'go' pushed down the eta-infos into the branch of a case - -- and the body of a let; and does beta-reduction if possible - -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn - go subst (Tick t e) eis - = Tick (substTickish subst t) (go subst e eis) - - go subst (Cast e co) (EI bs mco) - = go subst e (EI bs mco') - where - mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) - -- See Note [Check for reflexive casts in eta expansion] - - go subst (Case e b ty alts) eis - = Case (Core.substExprSC subst e) b1 ty' alts' - where - (subst1, b1) = Core.substBndr subst b - alts' = map subst_alt alts - ty' = etaInfoAppTy (Core.substTy subst ty) eis - subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) - where - (subst2,bs') = Core.substBndrs subst1 bs - - go subst (Let b e) eis - | not (isJoinBind b) -- See Note [Eta expansion for join points] - = Let b' (go subst' e eis) - where - (subst', b') = Core.substBindSC subst b - - -- Beta-reduction if possible, pushing any intervening casts past - -- the argument. See Note [The EtaInfo mechanism] - go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) - = go (Core.extendSubst subst v arg) e (EI bs mco') - - -- Stop pushing down; just wrap the expression up - -- See Note [Check for reflexive casts in eta expansion] - go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastMCo` checkReflexiveMCo mco - `mkVarApps` bs - --------------- -etaInfoAppTy :: Type -> EtaInfo -> Type --- If e :: ty --- then etaInfoApp e eis :: etaInfoApp ty eis -etaInfoAppTy ty (EI bs mco) - = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) - where - ty1 = case mco of - MRefl -> ty - MCo co -> coercionRKind co - --------------- -etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr --- See Note [The EtaInfo mechanism] -etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco - --------------- --- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding --- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the --- free variables of @e@. --- --- Note that this function is entirely unconcerned about cost centres and other --- semantically-irrelevant source annotations, so call sites must take care to --- preserve that info. See Note [Eta expansion and SCCs]. -mkEtaWW - :: [OneShotInfo] - -- ^ How many value arguments to eta-expand - -> SDoc - -- ^ The pretty-printed original expression, for warnings. - -> InScopeSet - -- ^ A super-set of the free vars of the expression to eta-expand. - -> Type - -> (InScopeSet, EtaInfo) - -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. - -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the - -- fresh variables in 'EtaInfo'. - -mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty - = go 0 orig_oss empty_subst orig_ty - where - empty_subst = mkEmptyTCvSubst in_scope - - go :: Int -- For fresh names - -> [OneShotInfo] -- Number of value args to expand to - -> TCvSubst -> Type -- We are really looking at subst(ty) - -> (InScopeSet, EtaInfo) - -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) - -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr - - go _ [] subst _ -- See Note [exprArity invariant] - ----------- Done! No more expansion needed - = (getTCvInScope subst, EI [] MRefl) - - go n oss@(one_shot:oss1) subst ty -- See Note [exprArity invariant] - ----------- Forall types (forall a. ty) - | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty - , (subst', tcv') <- Type.substVarBndr subst tcv - , let oss' | isTyVar tcv = oss - | otherwise = oss1 - -- A forall can bind a CoVar, in which case - -- we consume one of the [OneShotInfo] - , (in_scope, EI bs mco) <- go n oss' subst' ty' - = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco)) - - ----------- Function types (t1 -> t2) - | Just (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 - - , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) - -- Avoid free vars of the original expression - - , 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)) - - ----------- Newtypes - -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - | Just (co, ty') <- topNormaliseNewType_maybe ty - , -- co :: ty ~ ty' - let co' = Type.substCo subst co - -- Remember to apply the substitution to co (#16979) - -- (or we could have applied to ty, but then - -- we'd have had to zap it for the recursive call) - , (in_scope, EI bs mco) <- go n oss subst ty' - -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr - = (in_scope, EI bs (mkTransMCoR co' mco)) - - | otherwise -- We have an expression of arity > 0, - -- but its type isn't a function, or a binder - -- does not have a fixed runtime representation - = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) - (getTCvInScope subst, EI [] MRefl) - -- This *can* legitimately happen: - -- e.g. coerce Int (\x. x) Essentially the programmer is - -- playing fast and loose with types (Happy does this a lot). - -- So we simply decline to eta-expand. Otherwise we'd end up - -- with an explicit lambda having a non-function type - - -{- ********************************************************************* -* * - The "push rules" -* * -************************************************************************ - -Here we implement the "push rules" from FC papers: - -* The push-argument rules, where we can move a coercion past an argument. - We have - (fun |> co) arg - and we want to transform it to - (fun arg') |> co' - for some suitable co' and transformed arg'. - -* The PushK rule for data constructors. We have - (K e1 .. en) |> co - and we want to transform to - (K e1' .. en') - by pushing the coercion into the arguments --} - -pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) -pushCoArgs co [] = return ([], MCo co) -pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg - ; case m_co1 of - MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args - ; return (arg':args', m_co2) } - MRefl -> return (arg':args, MRefl) } - -pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -pushMCoArg MRefl arg = Just (arg, MRefl) -pushMCoArg (MCo co) arg = pushCoArg co arg - -pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) --- We have (fun |> co) arg, and we want to transform it to --- (fun arg) |> co --- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in GHC.Core.Opt.Simplify --- 'co' is always Representational -pushCoArg co arg - | Type ty <- arg - = do { (ty', m_co') <- pushCoTyArg co ty - ; return (Type ty', m_co') } - | otherwise - = do { (arg_mco, m_co') <- pushCoValArg co - ; let arg_mco' = checkReflexiveMCo arg_mco - -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] - -- The coercion is very often (arg_co -> res_co), but without - -- the argument coercion actually being ReflCo - ; return (arg `mkCastMCo` arg_mco', m_co') } - -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) --- We have (fun |> co) @ty --- Push the coercion through to return --- (fun @ty') |> co' --- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive; --- it's faster not to compute it, though. -pushCoTyArg co ty - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (ty, Nothing) - - | isReflCo co - = Just (ty, MRefl) - - | isForAllTy_ty tyL - = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, MCo co2) - - | otherwise - = Nothing - where - Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR - -- tyL = forall (a1 :: k1). ty1 - -- tyR = forall (a2 :: k2). ty2 - - co1 = mkSymCo (mkNthCo Nominal 0 co) - -- co1 :: k2 ~N k1 - -- Note that NthCo can extract a Nominal equality between the - -- kinds of the types related by a coercion between forall-types. - -- See the NthCo 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 - -pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) --- We have (fun |> co) arg --- Push the coercion through to return --- (fun (arg |> co_arg)) |> co_res --- 'co' is always Representational --- If the second returned Coercion is actually Nothing, then no cast is necessary; --- the returned coercion would have been reflexive. -pushCoValArg co - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (mkRepReflCo arg, Nothing) - - | isReflCo co - = Just (MRefl, MRefl) - - | isFunTy tyL - , (co_mult, co1, co2) <- decomposeFunCo Representational co - , isReflexiveCo co_mult - -- We can't push the coercion in the case where co_mult isn't reflexivity: - -- it could be an unsafe axiom, and losing this information could yield - -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) - -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int - -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed - - -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) - -- then co1 :: tyL1 ~ tyR1 - -- co2 :: tyL2 ~ tyR2 - = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $ - Just (coToMCo (mkSymCo co1), coToMCo co2) - -- Critically, coToMCo to checks for ReflCo; the whole coercion may not - -- be reflexive, but either of its components might be - -- We could use isReflexiveCo, but it's not clear if the benefit - -- is worth the cost, and it makes no difference in #18223 - - | otherwise - = Nothing - where - arg = funArgTy tyR - Pair tyL tyR = coercionKind co - -pushCoercionIntoLambda - :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) --- This implements the Push rule from the paper on coercions --- (\x. e) |> co --- ===> --- (\x'. e |> co') -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 - , isReflexiveCo co_mult - -- We can't push the coercion in the case where co_mult isn't - -- reflexivity. See pushCoValArg for more details. - = let - -- Should we optimize the coercions here? - -- Otherwise they might not match too well - x' = x `setIdType` t1 `setIdMult` w1 - in_scope' = in_scope `extendInScopeSet` x' - subst = extendIdSubst (mkEmptySubst in_scope') - x - (mkCast (Var x') (mkSymCo co1)) - -- We substitute x' for x, except we need to preserve types. - -- The types are as follows: - -- x :: s1, x' :: t1, co1 :: s1 ~# t1, - -- so we extend the substitution with x |-> (x' |> sym co1). - in Just (x', substExpr subst e `mkCast` co2) - | otherwise - -- See #21555 / #21577 for a case where this trace fired but the cause was benign - = -- pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion - -> Maybe (DataCon - , [Type] -- Universal type args - , [CoreExpr]) -- All other args incl existentials --- Implement the KPush reduction rule as described in "Down with kinds" --- The transformation applies iff we have --- (C e1 ... en) `cast` co --- where co :: (T t1 .. tn) ~ to_ty --- The left-hand one must be a T, because exprIsConApp returned True --- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args co - | isReflCo co || from_ty `eqType` to_ty -- try cheap test first - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, map exprToType univ_ty_args, rest_args) - - | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty - , to_tc == dataConTyCon dc - -- These two tests can fail; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there's nothing wrong with it - - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tcvars = dataConExTyCoVars dc - arg_tys = dataConRepArgTys dc - - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args - - -- Make the "Psi" from the paper - omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) - (psi_subst, to_ex_arg_tys) - = liftCoSubstWithEx Representational - dc_univ_tyvars - omegas - dc_ex_tcvars - (map exprToType ex_args) - - -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args - cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) - - to_ex_args = map Type to_ex_arg_tys - - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, - ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc - , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] - in - assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $ - assertPpr (equalLength val_args arg_tys) dump_doc $ - Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) - - | otherwise - = Nothing - - where - Pair from_ty to_ty = coercionKind co - -collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) --- Collect lambda binders, pushing coercions inside if possible --- E.g. (\x.e) |> g g :: -> blah --- = (\x. e |> Nth 1 g) --- --- That is, --- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) -collectBindersPushingCo e - = go [] e - where - -- Peel off lambdas until we hit a cast. - go :: [Var] -> CoreExpr -> ([Var], CoreExpr) - -- The accumulator is in reverse order - go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e co - go bs e = (reverse bs, e) - - -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) - go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) - - -- We are in a lambda under a cast; peel off lambdas and build a - -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co - | isTyVar b - , let Pair tyL tyR = coercionKind co - , assert (isForAllTy_ty tyL) $ - isForAllTy_ty tyR - , isReflCo (mkNthCo Nominal 0 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] - , 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 - , isReflCo co_mult -- See Note [collectBindersPushingCo] - , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res - - | otherwise = (reverse bs, mkCast (Lam b e) co) - -{- - -Note [collectBindersPushingCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We just look for coercions of form - % w -> blah -(and similarly for foralls) to keep this function simple. We could do -more elaborate stuff, but it'd involve substitution etc. - --} - -{- ********************************************************************* -* * - Join points -* * -********************************************************************* -} - -------------------- --- | Split an expression into the given number of binders and a body, --- eta-expanding if necessary. Counts value *and* type binders. -etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) -etaExpandToJoinPoint join_arity expr - = go join_arity [] expr - where - go 0 rev_bs e = (reverse rev_bs, e) - go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e - go n rev_bs e = case etaBodyForJoinPoint n e of - (bs, e') -> (reverse rev_bs ++ bs, e') - -etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule -etaExpandToJoinPointRule _ rule@(BuiltinRule {}) - = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule) - -- How did a local binding get a built-in rule anyway? Probably a plugin. - rule -etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs - , ru_args = args }) - | need_args == 0 - = rule - | need_args < 0 - = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) - | otherwise - = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args - , ru_rhs = new_rhs } - where - need_args = join_arity - length args - (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs - new_args = varsToCoreExprs new_bndrs - --- Adds as many binders as asked for; assumes expr is not a lambda -etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) -etaBodyForJoinPoint need_args body - = go need_args (exprType body) (init_subst body) [] body - where - go 0 _ _ rev_bs e - = (reverse rev_bs, e) - go n ty subst rev_bs e - | 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') - -- The varToCoreExpr is important: `tv` might be a coercion variable - | 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` varToCoreExpr b) - -- The varToCoreExpr is important: `b` might be a coercion variable - - | otherwise - = pprPanic "etaBodyForJoinPoint" $ int need_args $$ - ppr body $$ ppr (exprType body) - - init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) - - - --------------- -freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id) --- Make a fresh Id, with specified type (after applying substitution) --- It should be "fresh" in the sense that it's not in the in-scope set --- of the TvSubstEnv; and it should itself then be added to the in-scope --- set of the TvSubstEnv --- --- The Int is just a reasonable starting point for generating a unique; --- it does not necessarily have to be unique itself. -freshEtaId n subst ty - = (subst', eta_id') - where - Scaled mult' ty' = Type.substScaledTyUnchecked subst ty - eta_id' = uniqAway (getTCvInScope subst) $ - mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' - -- "OrCoVar" since this can be used to eta-expand - -- coercion abstractions - subst' = extendTCvInScope subst eta_id' + +-- | Arity and eta expansion +module GHC.Core.Opt.Arity + ( -- Finding arity + manifestArity, joinRhsArity, exprArity + , findRhsArity, cheapArityType + , ArityOpts(..) + + -- ** Eta expansion + , exprEtaExpandArity, etaExpand, etaExpandAT + + -- ** Eta reduction + , tryEtaReduce + + -- ** ArityType + , ArityType, mkBotArityType + , arityTypeArity, idArityType + + -- ** Bottoming things + , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe + + -- ** typeArity and the state hack + , typeArity, typeOneShots, typeOneShot + , isOneShotBndr + , isStateHackType + + -- * Lambdas + , zapLamBndrs + + + -- ** Join points + , etaExpandToJoinPoint, etaExpandToJoinPointRule + + -- ** Coercions and casts + , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg + , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.TyCon ( tyConArity ) +import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy ) +import GHC.Core.Multiplicity + +-- We have two sorts of substitution: +-- GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst +-- Both have substTy, substCo Hence need for qualification +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 ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Tickish + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Uniques + +import GHC.Data.FastString +import GHC.Data.Graph.UnVar +import GHC.Data.Pair + +import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness and CPR signatures. +-- It's used during float-out +exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e) + +arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) +-- Arity of a divergent function +arityTypeBotSigs_maybe (AT lams div) + | isDeadEndDiv div = Just ( arity + , mkVanillaDmdSig arity botDiv + , mkCprSig arity botCpr) + | otherwise = Nothing + where + arity = length lams + + +{- Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + typeArity and the "state hack" +* * +********************************************************************* -} + + +typeArity :: Type -> Arity +-- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after +-- looking through newtypes. More generally, (typeOneShots ty) returns +-- ty's [OneShotInfo], based only on the type itself, using typeOneShot +-- on the argument type to access the "state hack". +typeArity = length . typeOneShots + +typeOneShots :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [Arity invariants for bindings] +typeOneShots ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTyCoVar_maybe ty + = go rec_nts ty' + + | Just (_,_,arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes and products] + -- in GHC.Core.TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = OneShotLam + | otherwise = NoOneShotInfo + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = OneShotLam + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is +-- certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +isStateHackType :: Type -> Bool +isStateHackType ty + | unsafeHasNoStateHack -- Switch off with -fno-state-hack + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + + +{- Note [Arity invariants for bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following invariants for let-bindings + + (1) In any binding f = e, + idArity f <= typeArity (idType f) + We enforce this with trimArityType, called in findRhsArity; + see Note [Arity trimming]. + + Note that we enforce this only for /bindings/. We do /not/ insist that + arityTypeArity (arityType e) <= typeArity (exprType e) + because that is quite a bit more expensive to guaranteed; it would + mean checking at every Cast in the recursive arityType, for example. + + (2) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + (or less, of course). So the case analysis in etaExpand and in + typeArity must match. + + Consequence: because of (1), if we eta-expand to (idArity f), we will + end up with n manifest lambdas. + + (3) In any binding f = e, + idArity f <= arityTypeArity (safeArityType (arityType e)) + That is, we call safeArityType before attributing e's arityType to f. + See Note [SafeArityType]. + + So we call safeArityType in findRhsArity. + +Suppose we have + f :: Int -> Int -> Int + f x y = x+y -- Arity 2 + + g :: F Int + g = case of { True -> f |> co1 + ; False -> g |> co2 } + +where F is a type family. Now, we can't eta-expand g to have arity 2, +because etaExpand, which works off the /type/ of the expression +(albeit looking through newtypes), doesn't know how to make an +eta-expanded binding + g = (\a b. case x of ...) |> co +because it can't make up `co` or the types of `a` and `b`. + +So invariant (1) ensures that every binding has an arity that is no greater +than the typeArity of the RHS; and invariant (2) ensures that etaExpand +and handle what typeArity says. + +Why is this important? Because + + - In GHC.Iface.Tidy we use exprArity/manifestArity to fix the *final + arity* of each top-level Id, and in + + - In CorePrep we use etaExpand on each rhs, so that the visible + lambdas actually match that arity, which in turn means that the + StgRhs has a number of lambdas that precisely matches the arity. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity, +which calls trimArityType to trim the ArityType to match the Arity of the +binding. Failing to do so, and hence breaking invariant (1) led to #5441. + +How to trim? If we end in topDiv, it's easy. But we must take great care with +dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), +we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that +claims that ((\x y. error "urk") |> co) diverges when given one argument, +which it absolutely does not. And Bad Things happen if we think something +returns bottom when it doesn't (#16066). + +So, if we need to trim a dead-ending arity type, switch (conservatively) to +topDiv. + +Historical note: long ago, we unconditionally switched to topDiv when we +encountered a cast, but that is far too conservative: see #5475 + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- +-} + +{- ******************************************************************** +* * + Zapping lambda binders +* * +********************************************************************* -} + +zapLamBndrs :: FullArgCount -> [Var] -> [Var] +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear (in 't') under the \z. +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs +zapLamBndrs arg_count bndrs + | no_need_to_zap = bndrs + | otherwise = zap_em arg_count bndrs + where + no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) + + zap_em :: FullArgCount -> [Var] -> [Var] + zap_em 0 bs = bs + zap_em _ [] = [] + zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs + | otherwise = zapLamIdInfo b : zap_em (n-1) bs + + +{- ********************************************************************* +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divergent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC does some transformations that are technically unsound wrt +bottom, because doing so improves arities... a lot! We describe +them in this Note. + +The flag -fpedantic-bottoms (off by default) restore technically +correct behaviour at the cots of efficiency. + +It's mostly to do with eta-expansion. Consider + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +#5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it looks like this (see #22068) + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected behaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in #5557 + + (2) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +4. Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decompose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (#2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottoming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType can be thought of as an abstraction of an expression. +The ArityType + AT [ (IsCheap, NoOneShotInfo) + , (IsExpensive, OneShotLam) + , (IsCheap, OneShotLam) ] Dunno) + +abstracts an expression like + \x. let in + \y{os}. + \z{os}. blah + +In general we have (AT lams div). Then +* In lams :: [(Cost,OneShotInfo)] + * The Cost flag describes the part of the expression down + to the first (value) lambda. + * The OneShotInfo flag gives the one-shot info on that lambda. + +* If 'div' is dead-ending ('isDeadEndDiv'), then application to + 'length lams' arguments will surely diverge, similar to the situation + with 'DmdType'. + +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +We use the following notation: + at ::= \p1..pn.div + div ::= T | x | ⊥ + p ::= (c o) + c ::= X | C -- Expensive or Cheap + o ::= ? | 1 -- NotOneShot or OneShotLam +We may omit the \. if n = 0. +And ⊥ stands for `AT [] botDiv` + +Here is an example demonstrating the notation: + \(C?)(X1)(C1).T +stands for + AT [ (IsCheap,NoOneShotInfo) + , (IsExpensive,OneShotLam) + , (IsCheap,OneShotLam) ] + topDiv + +See the 'Outputable' instance for more information. It's pretty simple. + +How can we use ArityType? Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has arity type \(C?)(C?)(X1)(C1).T + The one-shot-ness means we can, in effect, push that + 'let' inside the \st, and expand to arity 4 + +Suppose f = \xy. x+y +Then f :: \(C?)(C?).T + f v :: \(C?).T + f :: \(X?).T + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ + definitely diverges. Partial applications to fewer than n args may *or + may not* diverge. Ditto exnDiv. + + * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at) + arguments without losing sharing. This function checks that the either + there are no expensive expressions, or the lambdas are one-shots. + + NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have + arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves + cheap. + + * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Wrinkles + +* Wrinkle [Bottoming functions]: see function 'arityLam'. + We treat bottoming functions as one-shot, because there is no point + in floating work outside the lambda, and it's fine to float it inside. + + For example, this is fine (see test stranal/sigs/BottomFromInnerLambda) + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + Idea: perhaps we could enforce this invariant with + data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost] + + +Note [SafeArityType] +~~~~~~~~~~~~~~~~~~~~ +The function safeArityType trims an ArityType to return a "safe" ArityType, +for which we use a type synonym SafeArityType. It is "safe" in the sense +that (arityTypeArity at) really reflects the arity of the expression, whereas +a regular ArityType might have more lambdas in its [ATLamInfo] that the +(cost-free) arity of the expression. + +For example + \x.\y.let v = expensive in \z. blah +has + arityType = AT [C?, C?, X?, C?] Top +But the expression actually has arity 2, not 4, because of the X. +So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo] +now reflects the (cost-free) arity of the expression + +Why do we ever need an "unsafe" ArityType, such as the example above? +Because its (cost-free) arity may increased by combineWithDemandOneShots +in findRhsArity. See Note [Combining arity type with demand info]. + +Thus the function `arityType` returns a regular "unsafe" ArityType, that +goes deeply into the lambdas (including under IsExpensive). But that is +very local; most ArityTypes are indeed "safe". We use the type synonym +SafeArityType to indicate where we believe the ArityType is safe. +-} + +-- | The analysis lattice of arity analysis. It is isomorphic to +-- +-- @ +-- data ArityType' +-- = AEnd Divergence +-- | ALam OneShotInfo ArityType' +-- @ +-- +-- Which is easier to display the Hasse diagram for: +-- +-- @ +-- ALam OneShotLam at +-- | +-- AEnd topDiv +-- | +-- ALam NoOneShotInfo at +-- | +-- AEnd exnDiv +-- | +-- AEnd botDiv +-- @ +-- +-- where the @at@ fields of @ALam@ are inductively subject to the same order. +-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. +-- +-- Why the strange Top element? +-- See Note [Combining case branches: optimistic one-shot-ness] +-- +-- We rely on this lattice structure for fixed-point iteration in +-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. +data ArityType -- See Note [ArityType] + = AT ![ATLamInfo] !Divergence + -- ^ `AT oss div` is an abstraction of the expression, which describes + -- its lambdas, and how much work appears where. + -- See Note [ArityType] for more information + -- + -- If `div` is dead-ending ('isDeadEndDiv'), then application to + -- `length os` arguments will surely diverge, similar to the situation + -- with 'DmdType'. + deriving Eq + +type ATLamInfo = (Cost,OneShotInfo) + -- ^ Info about one lambda in an ArityType + -- See Note [ArityType] + +type SafeArityType = ArityType -- See Note [SafeArityType] + +data Cost = IsCheap | IsExpensive + deriving( Eq ) + +allCosts :: (a -> Cost) -> [a] -> Cost +allCosts f xs = foldr (addCost . f) IsCheap xs + +addCost :: Cost -> Cost -> Cost +addCost IsCheap IsCheap = IsCheap +addCost _ _ = IsExpensive + +-- | This is the BNF of the generated output: +-- +-- @ +-- @ +-- +-- We format +-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and +-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. +-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. +-- If the one-shot info is empty, we omit the leading @\.@. +instance Outputable ArityType where + ppr (AT oss div) + | null oss = pp_div div + | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div + where + pp_div Diverges = char '⊥' + pp_div ExnOrDiv = char 'x' + pp_div Dunno = char 'T' + pp_os (IsCheap, OneShotLam) = text "(C1)" + pp_os (IsExpensive, OneShotLam) = text "(X1)" + pp_os (IsCheap, NoOneShotInfo) = text "(C?)" + pp_os (IsExpensive, NoOneShotInfo) = text "(X?)" + +mkBotArityType :: [OneShotInfo] -> ArityType +mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv + +botArityType :: ArityType +botArityType = mkBotArityType [] + +topArityType :: ArityType +topArityType = AT [] topDiv + +-- | The number of value args for the arity type +arityTypeArity :: SafeArityType -> Arity +arityTypeArity (AT lams _) = length lams + +arityTypeOneShots :: SafeArityType -> [OneShotInfo] +-- Returns a list only as long as the arity should be +arityTypeOneShots (AT lams _) = map snd lams + +safeArityType :: ArityType -> SafeArityType +-- ^ Assuming this ArityType is all we know, find the arity of +-- the function, and trim the argument info (and Divergence) +-- to match that arity. See Note [SafeArityType] +safeArityType at@(AT lams _) + = case go 0 IsCheap lams of + Nothing -> at -- No trimming needed + Just ar -> AT (take ar lams) topDiv + where + go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity + go _ _ [] = Nothing + go ar ch1 ((ch2,os):lams) + = case (ch1 `addCost` ch2, os) of + (IsExpensive, NoOneShotInfo) -> Just ar + (ch, _) -> go (ar+1) ch lams + +infixl 2 `trimArityType` + +trimArityType :: Arity -> ArityType -> ArityType +-- ^ Trim an arity type so that it has at most the given arity. +-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if +-- they end in 'ABot'. See Note [Arity trimming] +trimArityType max_arity at@(AT lams _) + | lams `lengthAtMost` max_arity = at + | otherwise = AT (take max_arity lams) topDiv + +data ArityOpts = ArityOpts + { ao_ped_bot :: !Bool -- See Note [Dealing with bottom] + , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries] + } + +-- | The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +-- Nothing if the expression has arity 0 +exprEtaExpandArity opts e + | AT [] _ <- arity_type + = Nothing + | otherwise + = Just arity_type + where + arity_type = safeArityType (arityType (findRhsArityEnv opts False) e) + + +{- ********************************************************************* +* * + findRhsArity +* * +********************************************************************* -} + +findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr + -> (Bool, SafeArityType) +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- +-- The Bool is True if the returned arity is greater than (exprArity rhs) +-- so the caller should do eta-expansion +-- That Bool is never True for join points, which are never eta-expanded +-- +-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr' +-- See Note [Arity trimming] + +findRhsArity opts is_rec bndr rhs + | isJoinId bndr + = (False, join_arity_type) + -- False: see Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + + | otherwise + = (arity_increased, non_join_arity_type) + -- arity_increased: eta-expand if we'll get more lambdas + -- to the top of the RHS + where + old_arity = exprArity rhs + + init_env :: ArityEnv + init_env = findRhsArityEnv opts (isJoinId bndr) + + -- Non-join-points only + non_join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> step init_env + arity_increased = arityTypeArity non_join_arity_type > old_arity + + -- Join-points only + -- See Note [Arity for non-recursive join bindings] + -- and Note [Arity for recursive join bindings] + join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> trimArityType ty_arity (cheapArityType rhs) + + ty_arity = typeArity (idType bndr) + id_one_shots = idDemandOneShots bndr + + step :: ArityEnv -> SafeArityType + step env = trimArityType ty_arity $ + safeArityType $ -- See Note [Arity invariants for bindings], item (3) + arityType env rhs `combineWithDemandOneShots` id_one_shots + -- trimArityType: see Note [Trim arity inside the loop] + -- combineWithDemandOneShots: take account of the demand on the + -- binder. Perhaps it is always called with 2 args + -- let f = \x. blah in (f 3 4, f 1 9) + -- f's demand-info says how many args it is called with + + -- The fixpoint iteration (go), done for recursive bindings. We + -- always do one step, but usually that produces a result equal + -- to old_arity, and then we stop right away, because old_arity + -- is assumed to be sound. In other words, arities should never + -- decrease. Result: the common case is that there is just one + -- iteration + go :: Int -> SafeArityType -> SafeArityType + go !n cur_at@(AT lams div) + | not (isDeadEndDiv div) -- the "stop right away" case + , length lams <= old_arity = cur_at -- from above + | next_at == cur_at = cur_at + | otherwise + -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] + = warnPprTrace (debugIsOn && n > 2) + "Exciting arity" + (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ + go (n+1) next_at + where + next_at = step (extendSigEnv init_env bndr cur_at) + +infixl 2 `combineWithDemandOneShots` + +combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType +-- See Note [Combining arity type with demand info] +combineWithDemandOneShots at@(AT lams div) oss + | null lams = at + | otherwise = AT (zip_lams lams oss) div + where + zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] + zip_lams lams [] = lams + zip_lams [] oss | isDeadEndDiv div = [] + | otherwise = [ (IsExpensive,OneShotLam) + | _ <- takeWhile isOneShotInfo oss] + zip_lams ((ch,os1):lams) (os2:oss) + = (ch, os1 `bestOneShot` os2) : zip_lams lams oss + +idDemandOneShots :: Id -> [OneShotInfo] +idDemandOneShots bndr + = call_arity_one_shots `zip_lams` dmd_one_shots + where + call_arity_one_shots :: [OneShotInfo] + call_arity_one_shots + | call_arity == 0 = [] + | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam + -- Call Arity analysis says the function is always called + -- applied to this many arguments. The first NoOneShotInfo is because + -- if Call Arity says "always applied to 3 args" then the one-shot info + -- we get is [NoOneShotInfo, OneShotLam, OneShotLam] + call_arity = idCallArity bndr + + dmd_one_shots :: [OneShotInfo] + -- If the demand info is C(x,C(1,C(1,.))) then we know that an + -- application to one arg is also an application to three + dmd_one_shots = argOneShots (idDemandInfo bndr) + + -- Take the *longer* list + zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2 + zip_lams [] lams2 = lams2 + zip_lams lams1 [] = lams1 + +{- Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in #4138. + +We do the necessary, quite simple fixed-point iteration in 'findRhsArity', +which assumes for a single binding 'ABot' on the first run and iterates +until it finds a stable arity type. Two wrinkles + +* We often have to ask (see the Case or Let case of 'arityType') whether some + expression is cheap. In the case of an application, that depends on the arity + of the application head! That's why we have our own version of 'exprIsCheap', + 'myExprIsCheap', that will integrate the optimistic arity types we have on + f and g into the cheapness check. + +* Consider this (#18793) + + go = \ds. case ds of + [] -> id + (x:ys) -> let acc = go ys in + case blah of + True -> acc + False -> \ x1 -> acc (negate x1) + + We must propagate go's optimistically large arity to @acc@, so that the + tail call to @acc@ in the True branch has sufficient arity. This is done + by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case + of 'arityType'. + +Note [Exciting arity] +~~~~~~~~~~~~~~~~~~~~~ +The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost +all cases. To get notified of cases where we need an usual number of iterations, +we emit a warning in debug mode, so that we can investigate and make sure that +we really can't do better. It's a gross hack, but catches real bugs (#18870). + +Now, which number is "unusual"? We pick n > 2. Here's a pretty common and +expected example that takes two iterations and would ruin the specificity +of the warning (from T18937): + + f :: [Int] -> Int -> Int + f [] = id + f (x:xs) = let y = sum [0..x] + in \z -> f xs (y + z) + +Fixed-point iteration starts with arity type ⊥ for f. After the first +iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally +'floatIn' the let-binding (see its bottom case). After the second iteration, +we get arity type \?.T, e.g. arity 1, because now we are no longer allowed +to floatIn the non-cheap let-binding. Which is all perfectly benign, but +means we do two iterations (well, actually 3 'step's to detect we are stable) +and don't want to emit the warning. + +Note [Trim arity inside the loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's an example (from gadt/nbe.hs) which caused trouble. + data Exp g t where + Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b) + + eval :: Exp g t -> g -> t + eval (Lam _ e) g = \a -> eval e (g,a) + +The danger is that we get arity 3 from analysing this; and the +next time arity 4, and so on for ever. Solution: use trimArityType +on each iteration. + +Note [Combining arity type with demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let f = \x. let y = in \p \q{os}. blah + in ...(f a b)...(f c d)... + +* From the RHS we get an ArityType like + AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno + where "?" means NoOneShotInfo + +* From the body, the demand analyser (or Call Arity) will tell us + that the function is always applied to at least two arguments. + +Combining these two pieces of info, we can get the final ArityType + AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno +result: arity=3, which is better than we could do from either +source alone. + +The "combining" part is done by combineWithDemandOneShots. It +uses info from both Call Arity and demand analysis. + +We may have /more/ call demands from the calls than we have lambdas +in the binding. E.g. + let f1 = \x. g x x in ...(f1 p q r)... + -- Demand on f1 is C(x,C(1,C(1,L))) + + let f2 = \y. error y in ...(f2 p q r)... + -- Demand on f2 is C(x,C(1,C(1,L))) + +In both these cases we can eta expand f1 and f2 to arity 3. +But /only/ for called-once demands. Suppose we had + let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)... + +Now we don't want to eta-expand f1 to have 3 args; only two. +Nor, in the case of f2, do we want to push that error call under +a lambda. Hence the takeWhile in combineWithDemandDoneShots. + +Note [Do not eta-expand join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similarly to CPR (see Note [Don't w/w join points for CPR] in +GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's +eta-expansion, and eta-expanding a join point is fraught with issues like how to +deal with a cast: + + let join $j1 :: IO () + $j1 = ... + $j2 :: Int -> IO () + $j2 n = if n > 0 then $j1 + else ... + + => + + let join $j1 :: IO () + $j1 = (\eta -> ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + $j2 :: Int -> IO () + $j2 n = (\eta -> if n > 0 then $j1 + else ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + +The cast here can't be pushed inside the lambda (since it's not casting to a +function type), so the lambda has to stay, but it can't because it contains a +reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather +than try and detect this situation (and whatever other situations crop up!), we +don't bother; again, any surrounding eta-expansion will improve these join +points anyway, since an outer cast can *always* be pushed inside. By the time +CorePrep comes around, the code is very likely to look more like this: + + let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) + $j1 = (...) eta + $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) + $j2 = if n > 0 then $j1 + else (...) eta + +Note [Arity for recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = joinrec j 0 = \ a b c -> (a,x,b) + j n = j (n-1) + in j 20 + +Obviously `f` should get arity 4. But it's a bit tricky: + +1. Remember, we don't eta-expand join points; see + Note [Do not eta-expand join points]. + +2. But even though we aren't going to eta-expand it, we still want `j` to get + idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity + for `f`, we'll call arityType on f's RHS: + - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType + for `j` (See Note [arityType for non-recursive let-bindings] + in GHC.Core.Opt.Arity)b + - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3 + result. + +3. All this, even though j's /join-arity/ (stored in the JoinId) is 1. + This is is the Main Reason that we want the idArity to sometimes be + larger than the join-arity c.f. Note [Invariants on join points] item 2b + in GHC.Core. + +4. Be very careful of things like this (#21755): + g x = let j 0 = \y -> (x,y) + j n = expensive n `seq` j (n-1) + in j x + Here we do /not/ want eta-expand `g`, lest we duplicate all those + (expensive n) calls. + + But it's fine: the findRhsArity fixpoint calculation will compute arity-1 + for `j` (not arity 2); and that's just what we want. But we do need that + fixpoint. + + Historical note: an earlier version of GHC did a hack in which we gave + join points an ArityType of ABot, but that did not work with this #21755 + case. + +5. arityType does not usually expect to encounter free join points; + see GHC.Core.Opt.Arity Note [No free join points in arityType]. + But consider + f x = join j1 y = .... in + joinrec j2 z = ...j1 y... in + j2 v + + When doing findRhsArity on `j2` we'll encounter the free `j1`. + But that is fine, because we aren't going to eta-expand `j2`; + we just want to know its arity. So we have a flag am_no_eta, + switched on when doing findRhsArity on a join point RHS. If + the flag is on, we allow free join points, but not otherwise. + + +Note [Arity for non-recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Arity for recursive join bindings] deals with recursive join +bindings. But what about /non-recursive/ones? If we just call +findRhsArity, it will call arityType. And that can be expensive when +we have deeply nested join points: + join j1 x1 = join j2 x2 = join j3 x3 = blah3 + in blah2 + in blah1 +(e.g. test T18698b). + +So we call cheapArityType instead. It's good enough for practical +purposes. + +(Side note: maybe we should use cheapArity for the RHS of let bindings +in the main arityType function.) +-} + + +{- ********************************************************************* +* * + arityType +* * +********************************************************************* -} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (AT oss div) + = AT ((IsCheap, one_shot) : oss) div + where + one_shot | isDeadEndDiv div = OneShotLam + | otherwise = idStateHackOneShotInfo id + -- If the body diverges, treat it as one-shot: no point + -- in floating out, and no penalty for floating in + -- See Wrinkle [Bottoming functions] in Note [ArityType] + +floatIn :: Cost -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +floatIn IsCheap at = at +floatIn IsExpensive at = addWork at + +addWork :: ArityType -> ArityType +-- Add work to the outermost level of the arity type +addWork at@(AT lams div) + = case lams of + [] -> at + lam:lams' -> AT (add_work lam : lams') div + +add_work :: ATLamInfo -> ATLamInfo +add_work (_,os) = (IsExpensive,os) + +arityApp :: ArityType -> Cost -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div) +arityApp at _ = at + +-- | Least upper bound in the 'ArityType' lattice. +-- See the haddocks on 'ArityType' for the lattice. +-- +-- Used for branches of a @case@. +andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType +andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) + | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) + = AT ((lam1 `and_lam` lam2) : lams') div' + where + (ch1,os1) `and_lam` (ch2,os2) + = ( ch1 `addCost` ch2, os1 `bestOneShot` os2) + -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] + +andArityType env (AT [] div1) at2 = andWithTail env div1 at2 +andArityType env at1 (AT [] div2) = andWithTail env div2 at1 + +andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType +andWithTail env div1 at2@(AT lams2 _) + | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } + = at2 -- See Note + | pedanticBottoms env -- [Combining case branches: andWithTail] + = AT [] topDiv + + | otherwise -- case x of { T -> plusInt ; F -> \y.e } + = AT (map add_work lams2) topDiv -- We know div1 = topDiv + -- See Note [Combining case branches: andWithTail] + +{- Note [Combining case branches: optimistic one-shot-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with +andArityType) and both ArityTypes have ATLamInfo, then we just combine +their expensive-ness and one-shot info. The tricky point is when we +have + + case x of True -> \x{one-shot). blah1 + Fale -> \y. blah2 + +Since one-shot-ness is about the /consumer/ not the /producer/, we +optimistically assume that if either branch is one-shot, we combine +the best of the two branches, on the (slightly dodgy) basis that if we +know one branch is one-shot, then they all must be. Surprisingly, +this means that the one-shot arity type is effectively the top element +of the lattice. + +Hence the call to `bestOneShot` in `andArityType`. + +Here's an example: + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x + +We *really* want to respect the one-shot annotation provided by the +user and eta-expand go and go2. In the first fixpoint iteration of +'go' we'll bind 'go' to botArityType (written \.⊥, see Note +[ArityType]). So 'z' will get arityType \.⊥; so we end up combining +the True and False branches: + + \.⊥ `andArityType` \1.T + +That gives \1.T (see Note [Combining case branches: andWithTail], +first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is +what we want. + +Note [Combining case branches: andWithTail] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with andArityType) +and one side or the other has run out of ATLamInfo; then we get +into `andWithTail`. + +* If one branch is guaranteed bottom (isDeadEndDiv), we just take + the other. Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + + Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely + diverge". So we need \??.⊥ for the whole thing, the /max/ of both + arities. + +* Otherwise, if pedantic-bottoms is on, we just have to return + AT [] topDiv. E.g. if we have + f x z = case x of True -> \y. blah + False -> z + then we can't eta-expand, because that would change the behaviour + of (f False bottom(). + +* But if pedantic-bottoms is not on, we allow ourselves to push + `z` under a lambda (much as we allow ourselves to put the `case x` + under a lambda). However we know nothing about the expensiveness + or one-shot-ness of `z`, so we'd better assume it looks like + (Expensive, NoOneShotInfo) all the way. Remembering + Note [Combining case branches: optimistic one-shot-ness], + we just add work to ever ATLamInfo, keeping the one-shot-ness. + +Note [Eta expanding through CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just as it's good to eta-expand through dictionaries, so it is good to +do so through CallStacks. #20103 is a case in point, where we got + foo :: HasCallStack => Int -> Int + foo = \(d::CallStack). let d2 = pushCallStack blah d in + \(x:Int). blah + +We really want to eta-expand this! #20103 is quite convincing! +We do this regardless of -fdicts-cheap; it's not really a dictionary. + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. +-} + +--------------------------- + +data ArityEnv + = AE { am_opts :: !ArityOpts + + , am_sigs :: !(IdEnv SafeArityType) + -- NB `SafeArityType` so we can use this in myIsCheapApp + -- See Note [Arity analysis] for details about fixed-point iteration. + + , am_free_joins :: !Bool -- True <=> free join points allowed + -- Used /only/ to support assertion checks + } + +instance Outputable ArityEnv where + ppr (AE { am_sigs = sigs, am_free_joins = free_joins }) + = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins + , text "sigs:" <+> ppr sigs ]) + +-- | The @ArityEnv@ used by 'findRhsArity'. +findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv +findRhsArityEnv opts free_joins + = AE { am_opts = opts + , am_free_joins = free_joins + , am_sigs = emptyVarEnv } + +freeJoinsOK :: ArityEnv -> Bool +freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins + +-- First some internal functions in snake_case for deleting in certain VarEnvs +-- of the ArityType. Don't call these; call delInScope* instead! + +modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv +modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs } +{-# INLINE modifySigEnv #-} + +del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! +del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id) +{-# INLINE del_sig_env #-} + +del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! +del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) +{-# INLINE del_sig_env_list #-} + +-- end of internal deletion functions + +extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv +extendSigEnv env id ar_ty + = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $ + env + +delInScope :: ArityEnv -> Id -> ArityEnv +delInScope env id = del_sig_env id env + +delInScopeList :: ArityEnv -> [Id] -> ArityEnv +delInScopeList env ids = del_sig_env_list ids env + +lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType +lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id + +-- | Whether the analysis should be pedantic about bottoms. +-- 'exprBotStrictness_maybe' always is. +pedanticBottoms :: ArityEnv -> Bool +pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot + +exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost +exprCost env e mb_ty + | myExprIsCheap env e mb_ty = IsCheap + | otherwise = IsExpensive + +-- | A version of 'exprIsCheap' that considers results from arity analysis +-- and optionally the expression's type. +-- Under 'exprBotStrictness_maybe', no expressions are cheap. +myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool +myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty + = cheap_dict || cheap_fun e + where + cheap_dict = case mb_ty of + Nothing -> False + Just ty -> (ao_dicts_cheap opts && isDictTy ty) + || isCallStackPredTy ty + -- See Note [Eta expanding through dictionaries] + -- See Note [Eta expanding through CallStacks] + + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + +-- | A version of 'isCheapApp' that considers results from arity analysis. +-- See Note [Arity analysis] for what's in the signature environment and why +-- it's important. +myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun +myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of + + -- Nothing means not a local function, fall back to regular + -- 'GHC.Core.Utils.isCheapApp' + Nothing -> isCheapApp fn n_val_args + + -- `Just at` means local function with `at` as current SafeArityType. + -- NB the SafeArityType bit: that means we can ignore the cost flags + -- in 'lams', and just consider the length + -- Roughly approximate what 'isCheapApp' is doing. + Just (AT lams div) + | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils + | n_val_args == 0 -> True -- Essentially + | n_val_args < length lams -> True -- isWorkFreeApp + | otherwise -> False + +---------------- +arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType +-- Precondition: all the free join points of the expression +-- are bound by the ArityEnv +-- See Note [No free join points in arityType] +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +arityType env (Var v) + | Just at <- lookupSigEnv env v -- Local binding + = at + | otherwise + = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $ + -- All join-point should be in the ae_sigs + -- See Note [No free join points in arityType] + idArityType v + +arityType env (Cast e _) + = arityType env e + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env' e) + | otherwise = arityType env' e + where + env' = delInScope env x + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp fun_at arg_cost + where + fun_at = arityType env fun + arg_cost = exprCost env arg Nothing + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' + -- +arityType env (Case scrut bndr _ alts) + | exprIsDeadEnd scrut || null alts + = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] + + | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] + , myExprIsCheap env scrut (Just (idType bndr)) + = alts_type + + | exprOkForSpeculation scrut + = alts_type + + | otherwise -- In the remaining cases we may not push + = addWork alts_type -- evaluation of the scrutinee in + where + env' = delInScope env bndr + arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs + alts_type = foldr1 (andArityType env) (map arity_type_alt alts) + +arityType env (Let (NonRec b rhs) e) + = -- See Note [arityType for non-recursive let-bindings] + floatIn rhs_cost (arityType env' e) + where + rhs_cost = exprCost env rhs (Just (idType b)) + env' = extendSigEnv env b (safeArityType (arityType env rhs)) + +arityType env (Let (Rec prs) e) + = -- See Note [arityType for recursive let-bindings] + floatIn (allCosts bind_cost prs) (arityType env' e) + where + bind_cost (b,e) = exprCost env' e (Just (idType b)) + env' = foldl extend_rec env prs + extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv + extend_rec env (b,_) = extendSigEnv env b $ + idArityType b + -- See Note [arityType for recursive let-bindings] + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = topArityType + +-------------------- +idArityType :: Id -> ArityType +idArityType v + | strict_sig <- idDmdSig v + , (ds, div) <- splitDmdSig strict_sig + , isDeadEndDiv div + = AT (takeList ds one_shots) div + + | isEmptyTy id_ty + = botArityType + + | otherwise + = AT (take (idArity v) one_shots) topDiv + where + id_ty = idType v + + one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type + one_shots = repeat IsCheap `zip` typeOneShots id_ty + +-------------------- +cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType +-- A fast and cheap version of arityType. +-- Returns an ArityType with IsCheap everywhere +-- c.f. GHC.Core.Utils.exprIsDeadEnd +-- +-- /Can/ encounter a free join-point Id; e.g. via the call +-- in exprBotStrictness_maybe, which is called in lots +-- of places +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +cheapArityType e = go e + where + go (Var v) = idArityType v + go (Cast e _) = go e + go (Lam x e) | isId x = arityLam x (go e) + | otherwise = go e + go (App e a) | isTypeArg a = go e + | otherwise = arity_app a (go e) + + go (Tick t e) | not (tickishIsCode t) = go e + + -- Null alts: see Note [Empty case alternatives] in GHC.Core + go (Case _ _ _ alts) | null alts = botArityType + + -- Give up on let, case. In particular, unlike arityType, + -- we make no attempt to look inside let's. + go _ = topArityType + + -- Specialised version of arityApp; all costs in ArityType are IsCheap + -- See Note [exprArity for applications] + -- NB: (1) coercions count as a value argument + -- (2) we use the super-cheap exprIsTrivial rather than the + -- more complicated and expensive exprIsCheap + arity_app _ at@(AT [] _) = at + arity_app arg at@(AT ((cost,_):lams) div) + | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $ + isDeadEndDiv div = AT lams div + | exprIsTrivial arg = AT lams topDiv + | otherwise = topArityType + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, even faster, version of 'cheapArityType' +-- Roughly exprArity e = arityTypeArity (cheapArityType e) +-- But it's a bit less clever about bottoms +-- +-- We do /not/ guarantee that exprArity e <= typeArity e +-- You may need to do arity trimming after calling exprArity +-- See Note [Arity trimming] +-- Reason: if we do arity trimming here we have take exprType +-- and that can be expensive if there is a large cast +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + +--------------- +exprIsDeadEnd :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +-- This function is, in effect, just a specialised (and hence cheap) +-- version of cheapArityType: +-- exprIsDeadEnd e = case cheapArityType e of +-- AT lams div -> null lams && isDeadEndDiv div +-- See also exprBotStrictness_maybe, which uses cheapArityType +exprIsDeadEnd e + = go 0 e + where + go :: Arity -> CoreExpr -> Bool + -- (go n e) = True <=> expr applied to n value args is bottom + go _ (Lit {}) = False + go _ (Type {}) = False + go _ (Coercion {}) = False + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + | otherwise = False + + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + + go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True + | isEmptyTy (idType v) = True + | otherwise = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsDeadEnd +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + +Note [No free join points in arityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we call arityType on this expression (EX1) + \x . case x of True -> \y. e + False -> $j 3 +where $j is a join point. It really makes no sense to talk of the arity +of this expression, because it has a free join point. In particular, we +can't eta-expand the expression because we'd have do the same thing to the +binding of $j, and we can't see that binding. + +If we had (EX2) + \x. join $j y = blah + case x of True -> \y. e + False -> $j 3 +then it would make perfect sense: we can determine $j's ArityType, and +propagate it to the usage site as usual. + +But how can we get (EX1)? It doesn't make much sense, because $j can't +be a join point under the \x anyway. So we make it a precondition of +arityType that the argument has no free join-point Ids. (This is checked +with an assert in the Var case of arityType.) + +Wrinkles + +* We /do/ allow free join point when doing findRhsArity for join-point + right-hand sides. See Note [Arity for recursive join bindings] + point (5) in GHC.Core.Opt.Simplify.Utils. + +* The invariant (no free join point in arityType) risks being + invalidated by one very narrow special case: runRW# + + join $j y = blah + runRW# (\s. case x of True -> \y. e + False -> $j x) + + We have special magic in OccurAnal, and Simplify to allow continuations to + move into the body of a runRW# call. + + So we are careful never to attempt to eta-expand the (\s.blah) in the + argument to runRW#, at least not when there is a literal lambda there, + so that OccurAnal has seen it and allowed join points bound outside. + See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. + +Note [arityType for non-recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For non-recursive let-bindings, we just get the arityType of the RHS, +and extend the environment. That works nicely for things like this +(#18793): + go = \ ds. case ds_a2CF of { + [] -> id + : y ys -> case y of { GHC.Types.I# x -> + let acc = go ys in + case x ># 42# of { + __DEFAULT -> acc + 1# -> \x1. acc (negate x2) + +Here we want to get a good arity for `acc`, based on the ArityType +of `go`. + +All this is particularly important for join points. Consider this (#18328) + + f x = join j y = case y of + True -> \a. blah + False -> \b. blah + in case x of + A -> j True + B -> \c. blah + C -> j False + +and suppose the join point is too big to inline. Now, what is the +arity of f? If we inlined the join point, we'd definitely say "arity +2" because we are prepared to push case-scrutinisation inside a +lambda. It's important that we extend the envt with j's ArityType, so +that we can use that information in the A/C branch of the case. + +Note [arityType for recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For /recursive/ bindings it's more difficult, to call arityType +(as we do in Note [arityType for non-recursive let-bindings]) +because we don't have an ArityType to put in the envt for the +recursively bound Ids. So for we satisfy ourselves with whizzing up +up an ArityType from the idArity of the function, via idArityType. + +That is nearly equivalent to deleting the binder from the envt, at +which point we'll call idArityType at the occurrences. But doing it +here means + + (a) we only call idArityType once, no matter how many + occurrences, and + + (b) we can check (in the arityType (Var v) case) that + we don't mention free join-point Ids. See + Note [No free join points in arityType]. + +But see Note [Arity for recursive join bindings] in +GHC.Core.Opt.Simplify.Utils for dark corners. +-} + +{- +%************************************************************************ +%* * + The main eta-expander +%* * +%************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alternative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The no-crap rule is very tiresome to guarantee when +we have join points. Consider eta-expanding + let j :: Int -> Int -> Bool + j x = e + in b + +The simple way is + \(y::Int). (let j x = e in b) y + +The no-crap way is + \(y::Int). let j' :: Int -> Bool + j' x = e y + in b[j'/j] y +where I have written to stress that j's type has +changed. Note that (of course!) we have to push the application +inside the RHS of the join as well as into the body. AND if j +has an unfolding we have to push it into there too. AND j might +be recursive... + +So for now I'm abandoning the no-crap rule in this case. I think +that for the use in CorePrep it really doesn't matter; and if +it does, then CoreToStg.myCollectArgs will fall over. + +(Moreover, I think that casts can make the no-crap rule fail too.) + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +Note [Eta expansion with ArityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The etaExpandAT function takes an ArityType (not just an Arity) to +guide eta-expansion. Why? Because we want to preserve one-shot info. +Consider + foo = \x. case x of + True -> (\s{os}. blah) |> co + False -> wubble +We'll get an ArityType for foo of \?1.T. + +Then we want to eta-expand to + foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co + +That 'eta' binder is fresh, and we really want it to have the +one-shot flag from the inner \s{os}. By expanding with the +ArityType gotten from analysing the RHS, we achieve this neatly. + +This makes a big difference to the one-shot monad trick; +see Note [The one-shot state monad trick] in GHC.Utils.Monad. +-} + +-- | @etaExpand n e@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n e +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' + +etaExpand :: Arity -> CoreExpr -> CoreExpr +etaExpand n orig_expr + = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr + where + in_scope = {-#SCC "eta_expand:in-scopeX" #-} + mkInScopeSet (exprFreeVars orig_expr) + +etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr +-- See Note [Eta expansion with ArityType] +-- +-- We pass in the InScopeSet from the simplifier to avoid recomputing +-- it here, which can be jolly expensive if the casts are big +-- In #18223 it took 10% of compile time just to do the exprFreeVars! +etaExpandAT in_scope at orig_expr + = eta_expand in_scope (arityTypeOneShots at) orig_expr + +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- possibly with a cast wrapped around the outside +-- See Note [Eta expansion with ArityType] +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) + +eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr +eta_expand in_scope one_shots (Cast expr co) + = mkCast (eta_expand in_scope one_shots expr) co + -- This mkCast is important, because eta_expand might return an + -- expression with a cast at the outside; and tryCastWorkerWrapper + -- asssumes that we don't have nested casts. Makes a difference + -- in compile-time for T18223 + +eta_expand in_scope one_shots orig_expr + = go in_scope one_shots [] orig_expr + where + -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- This is mainly to avoid spending time cloning binders and substituting + -- when there is actually nothing to do. It's slightly awkward to deal + -- with casts here, apart from the topmost one, and they are rare, so + -- if we find one we just hand off to mkEtaWW anyway + -- Note [Eta expansion and SCCs] + go _ [] _ _ = orig_expr -- Already has the specified arity; no-op + + go in_scope oss@(_:oss1) vs (Lam v body) + | isTyVar v = go (in_scope `extendInScopeSet` v) oss (v:vs) body + | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body + + go in_scope oss rev_vs expr + = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ + retick $ + etaInfoAbs top_eis $ + etaInfoApp in_scope' sexpr eis + where + (in_scope', eis@(EI eta_bndrs mco)) + = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + top_bndrs = reverse rev_vs + top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + -- I don't really understand this code SLPJ May 21 + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = mkApps expr'' args + retick expr = foldr mkTick expr ticks + +{- ********************************************************************* +* * + The EtaInfo mechanism + mkEtaWW, etaInfoAbs, etaInfoApp +* * +********************************************************************* -} + +{- Note [The EtaInfo mechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (e :: ty) and we want to eta-expand it to arity N. +This what eta_expand does. We do it in two steps: + +1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes + the shape of the expansion necessary to expand to arity N. + +2. Build the term + \ v1..vn. e v1 .. vn + where those abstractions and applications are described by + the same EtaInfo. Specifically we build the term + + etaInfoAbs etas (etaInfoApp in_scope e etas) + + where etas :: EtaInfo + etaInfoAbs builds the lambdas + etaInfoApp builds the applications + + Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp + +To a first approximation EtaInfo is just [Var]. But +casts complicate the question. If we have + newtype N a = MkN (S -> a) + axN :: N a ~ S -> a +and + e :: N (N Int) +then the eta-expansion should look like + (\(x::S) (y::S) -> (e |> co) x y) |> sym co +where + co :: N (N Int) ~ S -> S -> Int + co = axN @(N Int) ; (S -> axN @Int) + +We want to get one cast, at the top, to account for all those +nested newtypes. This is expressed by the EtaInfo type: + + data EtaInfo = EI [Var] MCoercionR + +Note [Check for reflexive casts in eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out that the casts created by the above mechanism are often Refl. +When casts are very deeply nested (as happens in #18223), the repetition +of types can make the overall term very large. So there is a big +payoff in cancelling out casts aggressively wherever possible. +(See also Note [No crap in eta-expanded code].) + +This matters particularly in etaInfoApp, where we +* Do beta-reduction on the fly +* Use getArg_maybe to get a cast out of the way, + so that we can do beta reduction +Together this makes a big difference. Consider when e is + case x of + True -> (\x -> e1) |> c1 + False -> (\p -> e2) |> c2 + +When we eta-expand this to arity 1, say, etaInfoAbs will wrap +a (\eta) around the outside and use etaInfoApp to apply each +alternative to 'eta'. We want to beta-reduce all that junk +away. + +#18223 was a dramatic example in which the intermediate term was +grotesquely huge, even though the next Simplifier iteration squashed +it. Better to kill it at birth. + +The crucial spots in etaInfoApp are: +* `checkReflexiveMCo` in the (Cast e co) case of `go` +* `checkReflexiveMCo` in `pushCoArg` +* Less important: checkReflexiveMCo in the final case of `go` +Collectively these make a factor-of-5 difference to the total +allocation of T18223, so take care if you change this stuff! + +Example: + newtype N = MkN (Y->Z) + f :: X -> N + f = \(x::X). ((\(y::Y). blah) |> fco) + +where fco :: (Y->Z) ~ N + +mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co + where + eta_co :: (X->N) ~ (X->Y->Z) + eta_co = ( -> nco) + nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe + +Now, when we push that eta_co inward in etaInfoApp: +* In the (Cast e co) case, the 'fco' and 'nco' will meet, and + should cancel. +* When we meet the (\y.e) we want no cast on the y. + +-} + +-------------- +data EtaInfo = EI [Var] MCoercionR + +-- (EI bs co) describes a particular eta-expansion, as follows: +-- Abstraction: (\b1 b2 .. bn. []) |> sym co +-- Application: ([] |> co) b1 b2 .. bn +-- +-- e :: T co :: T ~ (t1 -> t2 -> .. -> tn -> tr) +-- e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co + +instance Outputable EtaInfo where + ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) + + +etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr +-- (etaInfoApp s e (EI bs mco) returns something equivalent to +-- ((substExpr s e) |> mco b1 .. bn) +-- See Note [The EtaInfo mechanism] +-- +-- NB: With very deeply nested casts, this function can be expensive +-- In T18223, this function alone costs 15% of allocation, all +-- spent in the calls to substExprSC and substBindSC + +etaInfoApp in_scope expr eis + = go (mkEmptySubst in_scope) expr eis + where + go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr + -- 'go' pushed down the eta-infos into the branch of a case + -- and the body of a let; and does beta-reduction if possible + -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn + go subst (Tick t e) eis + = Tick (substTickish subst t) (go subst e eis) + + go subst (Cast e co) (EI bs mco) + = go subst e (EI bs mco') + where + mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) + -- See Note [Check for reflexive casts in eta expansion] + + go subst (Case e b ty alts) eis + = Case (Core.substExprSC subst e) b1 ty' alts' + where + (subst1, b1) = Core.substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (substTyUnchecked subst ty) eis + subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) + where + (subst2,bs') = Core.substBndrs subst1 bs + + go subst (Let b e) eis + | not (isJoinBind b) -- See Note [Eta expansion for join points] + = Let b' (go subst' e eis) + where + (subst', b') = Core.substBindSC subst b + + -- Beta-reduction if possible, pushing any intervening casts past + -- the argument. See Note [The EtaInfo mechanism] + go subst (Lam v e) (EI (b:bs) mco) + | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + = go (Core.extendSubst subst v arg) e (EI bs mco') + + -- Stop pushing down; just wrap the expression up + -- See Note [Check for reflexive casts in eta expansion] + go subst e (EI bs mco) = Core.substExprSC subst e + `mkCastMCo` checkReflexiveMCo mco + `mkVarApps` bs + +-------------- +etaInfoAppTy :: Type -> EtaInfo -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty (EI bs mco) + = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) + where + ty1 = case mco of + MRefl -> ty + MCo co -> coercionRKind co + +-------------- +etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr +-- See Note [The EtaInfo mechanism] +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco + +-------------- +-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding +-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the +-- free variables of @e@. +-- +-- Note that this function is entirely unconcerned about cost centres and other +-- semantically-irrelevant source annotations, so call sites must take care to +-- preserve that info. See Note [Eta expansion and SCCs]. +mkEtaWW + :: [OneShotInfo] + -- ^ How many value arguments to eta-expand + -> SDoc + -- ^ The pretty-printed original expression, for warnings. + -> InScopeSet + -- ^ A super-set of the free vars of the expression to eta-expand. + -> Type + -> (InScopeSet, EtaInfo) + -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. + -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the + -- fresh variables in 'EtaInfo'. + +mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty + = go 0 orig_oss empty_subst orig_ty + where + empty_subst = mkEmptySubst in_scope + + go :: Int -- For fresh names + -> [OneShotInfo] -- Number of value args to expand to + -> Subst -> Type -- We are really looking at subst(ty) + -> (InScopeSet, EtaInfo) + -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) + -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr + + go _ [] subst _ + ----------- Done! No more expansion needed + = (getSubstInScope subst, EI [] MRefl) + + go n oss@(one_shot:oss1) subst ty + ----------- Forall types (forall a. ty) + | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty + , (subst', tcv') <- Type.substVarBndr subst tcv + , let oss' | isTyVar tcv = oss + | otherwise = oss1 + -- A forall can bind a CoVar, in which case + -- we consume one of the [OneShotInfo] + , (in_scope, EI bs mco) <- go n oss' subst' ty' + = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco)) + + ----------- Function types (t1 -> t2) + | 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 + + , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) + -- Avoid free vars of the original expression + + , 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 eta_id' mco)) + + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + | Just (co, ty') <- topNormaliseNewType_maybe ty + , -- co :: ty ~ ty' + let co' = Type.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + , (in_scope, EI bs mco) <- go n oss subst ty' + -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr + = (in_scope, EI bs (mkTransMCoR co' mco)) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function, or a binder + -- does not have a fixed runtime representation + = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) + (getSubstInScope subst, EI [] MRefl) + -- This *can* legitimately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction makes sense] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +We discuss when this is /sound/ in Note [Eta reduction soundness]. +But even assuming it is sound, when is it /desirable/. That +is what we discuss here. + +This test is made by `ok_fun` in tryEtaReduce. + +1. We want to eta-reduce only if we get all the way to a trivial + expression; we don't want to remove extra lambdas unless we are + going to avoid allocating this thing altogether. + + Trivial means *including* casts and type lambdas: + * `\x. f x |> co --> f |> (ty(x) -> co)` (provided `co` doesn't mention `x`) + * `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)` + See Note [Do not eta reduce PAPs] for why we insist on a trivial head. + +2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it + is always sound to reduce /type lambdas/, thus: + (/\a -> f a) --> f + Moreover, we always want to, because it makes RULEs apply more often: + This RULE: `forall g. foldr (build (/\a -> g a))` + should match `foldr (build (/\b -> ...something complex...))` + and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. + + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc (all ok_lam bndrs) + +Of course, eta reduction is not always sound. See Note [Eta reduction soundness] +for when it is. + +When there are multiple arguments, we might get multiple eta-redexes. Example: + \x y. e x y + ==> { reduce \y. (e x) y in context \x._ } + \x. e x + ==> { reduce \x. e x in context _ } + e +And (1) implies that we never want to stop with `\x. e x`, because that is not a +trivial expression. So in practice, the implementation works by considering a +whole group of leading lambdas to reduce. + +These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF' +in 'tryEtaReduce'. Alas. + +Note [Eta reduction soundness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +For soundness, we obviously require that `x` and `y` +to not occur free. But what /other/ restrictions are there for +eta reduction to be sound? + +We discuss separately what it means for eta reduction to be +/desirable/, in Note [Eta reduction makes sense]. + +Eta reduction is *not* a sound transformation in general, because it +may change termination behavior if *value* lambdas are involved: + `bot` /= `\x. bot x` (as can be observed by a simple `seq`) +The past has shown that oversight of this fact can not only lead to endless +loops or exceptions, but also straight out *segfaults*. + +Nevertheless, we can give the following criteria for when it is sound to +perform eta reduction on an expression with n leading lambdas `\xs. e xs` +(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the +case where `e` is trivial): + + A. It is sound to eta-reduce n arguments as long as n does not exceed the + `exprArity` of `e`. (Needs Arity analysis.) + This criterion exploits information about how `e` is *defined*. + + Example: If `e = \x. bot` then we know it won't diverge until it is called + with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`. + By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`: + `e 42` diverges when `(\x y. e x y) 42` does not. + + S. It is sound to eta-reduce n arguments in an evaluation context in which all + calls happen with at least n arguments. (Needs Strictness analysis.) + NB: This treats evaluations like a call with 0 args. + NB: This criterion exploits information about how `e` is *used*. + + Example: Given a function `g` like + `g c = Just (c 1 2 + c 2 3)` + it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without + knowing *anything* about `e` (perhaps it's a parameter occ itself), simply + because `g` always calls its parameter with 2 arguments. + It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`. + By contrast, it would *unsound* to eta-reduce 3 args in a call site + like `g (\x y z. e x y z)` to `g e`, because that diverges when + `e = \x y. bot`. + + Could we relax to "*At least one call in the same trace* is with n args"? + No. Consider what happens for + ``g2 c = c True `seq` c False 42`` + Here, `g2` will call `c` with 2 arguments (if there is a call at all). + But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e` + when `e = \x. if x then bot else id`, because the latter will diverge when + the former would not. Fortunately, the strictness analyser will report + "Not always called with two arguments" for `g2` and we won't eta-expand. + + See Note [Eta reduction based on evaluation context] for the implementation + details. This criterion is tested extensively in T21261. + + R. Note [Eta reduction in recursive RHSs] tells us that we should not + eta-reduce `f` in its own RHS and describes our fix. + There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which + might change a terminating program (think @f `seq` e@) to a non-terminating + one. + + E. (See fun_arity in tryEtaReduce.) As a perhaps special case on the + boundary of (A) and (S), when we know that a fun binder `f` is in + WHNF, we simply assume it has arity 1 and apply (A). Example: + g f = f `seq` \x. f x + Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom + after the `seq`. This turned up in #7542. + +And here are a few more technical criteria for when it is *not* sound to +eta-reduce that are specific to Core and GHC: + + L. With linear types, eta-reduction can break type-checking: + f :: A ⊸ B + g :: A -> B + g = \x. f x + The above is correct, but eta-reducing g would yield g=f, the linter will + complain that g and f don't have the same type. NB: Not unsound in the + dynamic semantics, but unsound according to the static semantics of Core. + + J. We may not undersaturate join points. + See Note [Invariants on join points] in GHC.Core, and #20599. + + B. We may not undersaturate functions with no binding. + See Note [Eta expanding primops]. + + W. We may not undersaturate StrictWorkerIds. + See Note [CBV Function Ids] in GHC.Types.Id.Info. + +Here is a list of historic accidents surrounding unsound eta-reduction: + +* Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). + [SG in 2022: I don't think worker/wrapper would do this today.] + BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also + wrongly). So CorePrep eta-expands the definition again, so that it does not + terminate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + [SG in 2022: I don't understand this point. There is no `h`, perhaps that + should have been `g`. Even then, this proposed eta-reduction is invalid by + criterion (A), which might actually be the point this anecdote is trying to + make. Perhaps the "no arity decrease" idea is also related to + Note [Arity robustness]?] + +Note [Do not eta reduce PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I considered eta-reducing if the result is a PAP: + \x. f e1 e2 x ==> f e1 e2 + +This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] +in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand +a PAP. If eta-expanding is bad, then eta-reducing is good! + +Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep +Note [No eta reduction needed in rhsToBody]. + +But note that we don't want to eta-reduce + \x y. f x y +to + f +The former has arity 2, and repeats for every call of the +function; the latter has arity 0, and shares . We don't want +to change behaviour. Hence the call to exprIsCheap in ok_fun. + +I noticed this when examining #18993 and, although it is delicate, +eta-reducing to a PAP happens to fix the regression in #18993. + +HOWEVER, if we transform + \x. f y x ==> f y +that might mean that f isn't saturated any more, and does not inline. +This led to some other regressions. + +TL;DR currently we do /not/ eta reduce if the result is a PAP. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +Note [Eta reduction with casted function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since we are pushing a coercion inwards, it is easy to accommodate + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) + +See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The +eta-expander pushes those casts outwards, so you might think we won't +ever see a cast here, but if we have + \xy. (f x y |> g) +we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to +work. This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where +eta-expansion may be turned off (by sm_eta_expand). + +Note [Eta reduction based on evaluation context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Eta reduction soundness], criterion (S) allows us to eta-reduce +`g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with +at least 2 arguments. So how do we read that off `g`'s demand signature? + +Let's take the simple example of #21261, where `g` (actually, `f`) is defined as + g c = c 1 2 + c 3 4 +Then this is how the pieces are put together: + + * Demand analysis infers `` for `g`'s demand signature + + * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it + looks up the *evaluation context* of the argument in the form of the + sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'. + (Why does it drop the outer evaluation cardinality of the demand, `S`? + Because it's irrelevant! When we simplify an expression, we do so under the + assumption that it is currently under evaluation.) + This sub-demand literally says "Whenever this expression is evaluated, it + is called with at least two arguments, potentially multiple times". + + * Then the simplifier takes apart the lambda and simplifies the lambda group + and then calls 'tryEtaReduce' when rebuilding the lambda, passing the + evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call + sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and + `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce + `\x y. e x y` to `e`. + +Note [Eta reduction in recursive RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following recursive function: + f = \x. ....g (\y. f y).... +The recursive call of f in its own RHS seems like a fine opportunity for +eta-reduction because f has arity 1. And often it is! + +Alas, that is unsound in general if the eta-reduction happens in a tail context. +Making the arity visible in the RHS allows us to eta-reduce + f = \x -> f x +to + f = f +which means we optimise terminating programs like (f `seq` ()) into +non-terminating ones. Nor is this problem just for tail calls. Consider + f = id (\x -> f x) +where we have (for some reason) not yet inlined `id`. We must not eta-reduce to + f = id f +because that will then simplify to `f = f` as before. + +An immediate idea might be to look at whether the called function is a local +loopbreaker and refrain from eta-expanding. But that doesn't work for mutually +recursive function like in #21652: + f = g + g* x = f x +Here, g* is the loopbreaker but f isn't. + +What can we do? + +Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when + entering the let body. + Has the disadvantage that other transformations which make use of arity + (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. + Plus it requires non-trivial refactorings to both the simple optimiser (in + the way `subst_opt_bndr` is used) as well as the Simplifier (in the way + `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's + substitution twice in the process. A very complicated stop-gap. + +Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are + the ones we should not eta-reduce. All call-site must maintain this set. + Example: + rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... + ; f2 = ...f1... } + when eta-reducing those inner lambdas, we need to know that we are in the + rec group for {f1, f2, g}. + This is very much like the solution in Note [Speculative evaluation] in + GHC.CoreToStg.Prep. + It is a bit tiresome to maintain this info, because it means another field + in SimplEnv and SimpleOptEnv. + +We implement Fix (2) because of it isn't as complicated to maintain as (1). +Plus, it is the correct fix to begin with. After all, the arity is correct, +but doing the transformation isn't. The moving parts are: + * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders + * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` + * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` +The situation is very similar to Note [Speculative evaluation] which has the +same fix. +-} + +-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated +-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`. +-- See Note [Eta reduction soundness] +-- and Note [Eta reduction makes sense] when that is the case. +tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr +-- Return an expression equal to (\bndrs. body) +tryEtaReduce rec_ids bndrs body eval_sd + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + -- + -- Invariant: (go bs body co) returns an expression + -- equivalent to (\(reverse bs). (body |> co)) + + -- See Note [Eta reduction with casted function] + go bs (Cast e co1) co2 + = go bs e (co1 `mkTransCo` co2) + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go remaining_bndrs fun co + | all isTyVar remaining_bndrs + -- If all the remaining_bnrs are tyvars, then the etad_exp + -- will be trivial, which is what we want. + -- e.g. We might have /\a \b. f [a] b, and we want to + -- eta-reduce to /\a. f [a] + -- We don't want to give up on this one: see #20040 + -- See Note [Eta reduction makes sense], point (1) + , remaining_bndrs `ltLength` bndrs + -- Only reply Just if /something/ has happened + , ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs) + -- reduced_bndrs are the ones we are eta-reducing away + , used_vars `disjointVarSet` reduced_bndrs + -- Check for any of the reduced_bndrs (about to be dropped) + -- free in the result, including the accumulated coercion. + -- See Note [Eta reduction makes sense], intro and point (1) + -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) + -- because the latter may be ill formed if the guard fails (#21801) + = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) + + go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ + Nothing + + --------------- + -- See Note [Eta reduction makes sense], point (1) + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = is_eta_reduction_sound fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + -- See Note [Eta reduction soundness], this is THE place to check soundness! + is_eta_reduction_sound fun = + -- Don't eta-reduce in fun in its own recursive RHSs + not (fun `elemUnVarSet` rec_ids) -- criterion (R) + -- Check that eta-reduction won't make the program stricter... + && (fun_arity fun >= incoming_arity -- criterion (A) and (E) + || all_calls_with_arity incoming_arity) -- criterion (S) + -- ... and that the function can be eta reduced to arity 0 + -- without violating invariants of Core and GHC + && canEtaReduceToArity fun 0 0 -- criteria (L), (J), (W), (B) + all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd) + -- See Note [Eta reduction based on evaluation context] + + --------------- + fun_arity fun + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction soundness], criterion (E) + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + -- See Note [Eta reduction makes sense], point (2) + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Type -- Type (arg_t -> t1) of the function + -- to which the argument is supplied + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [CoreTickish]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co _ + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , 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 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 + , bndr == v + , fun_mult `eqType` idMult bndr + = 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 + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + = Just (co', t:ticks) + + ok_arg _ _ _ _ = Nothing + +-- | Can we eta-reduce the given function to the specified arity? +-- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L). +canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool +canEtaReduceToArity fun dest_join_arity dest_arity = + not $ + hasNoBinding fun -- (B) + -- Don't undersaturate functions with no binding. + + || ( isJoinId fun && dest_join_arity < idJoinArity fun ) -- (J) + -- Don't undersaturate join points. + -- See Note [Invariants on join points] in GHC.Core, and #20599 + + || ( dest_arity < idCbvMarkArity fun ) -- (W) + -- Don't undersaturate StrictWorkerIds. + -- See Note [CBV Function Ids] in GHC.Types.Id.Info. + + || isLinearType (idType fun) -- (L) + -- Don't perform eta reduction on linear types. + -- If `f :: A %1-> B` and `g :: A -> B`, + -- then `g x = f x` is OK but `g = f` is not. + + +{- ********************************************************************* +* * + The "push rules" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and transformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to transform to + (K e1' .. en') + by pushing the coercion into the arguments +-} + +pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) +pushCoArgs co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushMCoArg MRefl arg = Just (arg, MRefl) +pushMCoArg (MCo co) arg = pushCoArg co arg + +pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in GHC.Core.Opt.Simplify +-- 'co' is always Representational +pushCoArg co arg + | Type ty <- arg + = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } + | otherwise + = do { (arg_mco, m_co') <- pushCoValArg co + ; let arg_mco' = checkReflexiveMCo arg_mco + -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] + -- The coercion is very often (arg_co -> res_co), but without + -- the argument coercion actually being ReflCo + ; return (arg `mkCastMCo` arg_mco', m_co') } + +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive; +-- it's faster not to compute it, though. +pushCoTyArg co ty + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (ty, Nothing) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~R tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkSelCo SelForAll co) + -- co1 :: k2 ~N k1 + -- Note that SelCo extracts a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the SelCo case in GHC.Core.Lint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- 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 +-- +-- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) +-- +-- or, equivalently +-- +-- > (fun |> co) arg = (fun (arg |> co_arg)) |> co_res +-- +-- If the LHS is well-typed, then so is the RHS. In particular, the argument +-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) +pushCoValArg co + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (mkRepReflCo arg, Nothing) + + | isReflCo co + = Just (MRefl, MRefl) + + | isFunTy tyL + , (co_mult, co1, co2) <- decomposeFunCo co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't reflexivity: + -- it could be an unsafe axiom, and losing this information could yield + -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) + -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int + -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed. + + , typeHasFixedRuntimeRep new_arg_ty + -- We can't push the coercion inside if it would give rise to + -- a representation-polymorphic argument. + + = assertPpr (isFunTy tyL && isFunTy tyR) + (vcat [ text "co:" <+> ppr co + , text "old_arg_ty:" <+> ppr old_arg_ty + , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ + Just (coToMCo (mkSymCo co1), coToMCo co2) + -- Critically, coToMCo to checks for ReflCo; the whole coercion may not + -- be reflexive, but either of its components might be + -- We could use isReflexiveCo, but it's not clear if the benefit + -- is worth the cost, and it makes no difference in #18223 + + | otherwise + = Nothing + where + old_arg_ty = funArgTy tyR + new_arg_ty = funArgTy tyL + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | assert (not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind 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. + , typeHasFixedRuntimeRep t1 + -- We can't push the coercion into the lambda if it would create + -- a representation-polymorphic binder. + = let + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 `setIdMult` w1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') (mkSymCo co1)) + -- We substitute x' for x, except we need to preserve types. + -- The types are as follows: + -- x :: s1, x' :: t1, co1 :: s1 ~# t1, + -- so we extend the substitution with x |-> (x' |> sym co1). + in Just (x', substExpr subst e `mkCast` co2) + | otherwise + = Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> Maybe (DataCon + , [Type] -- Universal type args + , [CoreExpr]) -- All other args incl existentials +-- Implement the KPush reduction rule as described in "Down with kinds" +-- The transformation applies iff we have +-- (C e1 ... en) `cast` co +-- where co :: (T t1 .. tn) ~ to_ty +-- The left-hand one must be a T, because exprIsConApp returned True +-- but the right-hand one might not be. (Though it usually will.) +pushCoDataCon dc dc_args co + | isReflCo co || from_ty `eqType` to_ty -- try cheap test first + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, map exprToType univ_ty_args, rest_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there's nothing wrong with it + + = let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc + , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] + in + assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $ + assertPpr (equalLength val_args arg_tys) dump_doc $ + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> SelCo (SelFun SelRes) g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , assert (isForAllTy_ty tyL) $ + isForAllTy_ty tyR + , 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 (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 co + , isReflCo co_mult -- See Note [collectBindersPushingCo] + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- + +Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + % w -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. + +-} + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +------------------- +-- | Split an expression into the given number of binders and a body, +-- eta-expanding if necessary. Counts value *and* type binders. +etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) +etaExpandToJoinPoint join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args + , ru_rhs = new_rhs } + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- Adds as many binders as asked for; assumes expr is not a lambda +etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) +etaBodyForJoinPoint need_args body + = go need_args (exprType body) (init_subst body) [] body + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | 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') + -- The varToCoreExpr is important: `tv` might be a coercion variable + + | 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` varToCoreExpr b) + -- The varToCoreExpr is important: `b` might be a coercion variable + + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e)) + + + +-------------- +freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + Scaled mult' ty' = Type.substScaledTyUnchecked subst ty + eta_id' = uniqAway (getSubstInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' + -- "OrCoVar" since this can be used to eta-expand + -- coercion abstractions + subst' = extendSubstInScope subst eta_id' diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -27,12 +27,10 @@ import GHC.Prelude import GHC.Utils.Outputable as Outputable import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) import GHC.Types.Tickish -import GHC.Unit.Module.Name import GHC.Unit.Module.ModGuts import GHC.Types.SrcLoc import GHC.Types.Var @@ -44,6 +42,8 @@ import qualified GHC.Utils.Binary as B import Data.Char +import Language.Haskell.Syntax.Module.Name + addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do dflags <- getDynFlags @@ -52,7 +52,7 @@ env = Env { thisModule = mg_module guts , ccState = newCostCentreState - , dflags = dflags + , countEntries = gopt Opt_ProfCountEntries dflags , revParents = [] , filters = filters } @@ -78,13 +78,13 @@ hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v) ccName :: CcName - ccName = mkFastString $ showSDoc (dflags env) nameDoc + ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc ccIdx <- getCCIndex' ccName - let count = gopt Opt_ProfCountEntries (dflags env) + let count = countEntries env span = case revParents env of top:_ -> nameSrcSpan $ varName top _ -> noSrcSpan - cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span + cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span tick :: CoreTickish tick = ProfNote cc count True pure $ Tick tick e @@ -109,7 +109,7 @@ data Env = Env { thisModule :: Module - , dflags :: DynFlags + , countEntries :: !Bool , ccState :: CostCentreState , revParents :: [Id] , filters :: [CallerCcFilter] diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -34,7 +34,7 @@ import GHC.Platform -import GHC.Types.Id.Make ( voidPrimId ) +import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -46,10 +46,12 @@ 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 @@ -69,7 +71,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Applicative ( Alternative(..) ) import Control.Monad @@ -419,15 +420,14 @@ [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 @@ -- 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 @@ 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 @@ -------------------------- 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,9 +1110,8 @@ -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) - = Just $ mkCoreUbxTup [int64PrimTy, intPrimTy] - [ Lit (mkLitInt64Wrap (toInteger m)) - , mkIntVal platform (toInteger e) ] + = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m)) + , mkIntVal platform (toInteger e) ] where platform = roPlatform env doubleDecodeOp _ _ @@ -1221,9 +1218,8 @@ -- 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 @@ -1263,9 +1259,8 @@ -- 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 @@ -1282,7 +1277,7 @@ word64Result' result = Lit (mkLitWord64Wrap result) --- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'. +-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'. semiInversePrimOp :: PrimOp -> RuleM CoreExpr semiInversePrimOp primop = do [Var primop_id `App` e] <- getArgs @@ -1409,11 +1404,11 @@ let x = I# (error "invalid shift") in ... -This was originally done in the fix to #16449 but this breaks the let/app -invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742. -For the reasons discussed in Note [Checking versus non-checking primops] (in -the PrimOp module) there is no safe way rewrite the argument of I# such that -it bottoms. +This was originally done in the fix to #16449 but this breaks the let-can-float +invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in #16742. +For the reasons discussed in Note [Checking versus non-checking +primops] (in the PrimOp module) there is no safe way to rewrite the argument of I# +such that it bottoms. Consequently we instead take advantage of the fact that large shifts are undefined behavior (see associated documentation in primops.txt.pp) and @@ -1619,7 +1614,7 @@ [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 @@ -1636,7 +1631,7 @@ [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 = @@ -1811,7 +1806,7 @@ -- See Note [tagToEnum#] _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ - return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type" ------------------------------ dataToTagRule :: RuleM CoreExpr @@ -1830,12 +1825,12 @@ -- dataToTag x -- where x's unfolding is a constructor application b = do - dflags <- getPlatform + platform <- getPlatform [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg massert (not (isNewTyCon (dataConTyCon dc))) - return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) {- Note [dataToTag# magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1951,9 +1946,9 @@ 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 @@ -2098,10 +2093,10 @@ x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 -- return an unboxed sum: (# (# #) | Natural #) - let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v + let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v platform <- getPlatform if x < y - then ret 1 $ Var voidPrimId + then ret 1 unboxedUnitExpr else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations @@ -2131,12 +2126,12 @@ , 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 @@ -2238,7 +2233,7 @@ -- We use a host Int to compute the popCount. If we compile on a 32-bit -- host for a 64-bit target, the result may be different than if computed -- by the target. So we disable this rule if sizes don't match. - guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) + guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word)) [a0] <- getArgs x <- isBignumLiteral a0 pure $ Lit (mk_lit platform (fromIntegral (popCount x))) @@ -2286,14 +2281,14 @@ 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 @@ -2403,7 +2398,7 @@ -- Also, look into variable's unfolding just in case the expression we look for -- is in a top-level thunk. stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr) -stripStrTopTicks (_,id_unf) e = case e of +stripStrTopTicks (ISE _ id_unf) e = case e of Var v | Just rhs <- expandUnfolding_maybe (id_unf v) -> stripTicksTop tickishFloatable rhs @@ -2903,7 +2898,7 @@ andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of - -- R2) * `or` `and` simplications + -- R2) * `or` `and` simplifications -- l1 and (l2 and x) ==> (l1 and l2) and x (L l1, is_lit_and num_ops -> Just (l2, x)) -> Just (mkL (l1 .&. l2) `and` x) @@ -2926,7 +2921,7 @@ orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of - -- R2) * `or` `and` simplications + -- R2) * `or` `and` simplifications -- l1 or (l2 or x) ==> (l1 or l2) or x (L l1, is_lit_or num_ops -> Just (l2, x)) -> Just (mkL (l1 .|. l2) `or` x) diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -6,31 +6,22 @@ {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Core.Opt.Monad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - SimplMode(..), + -- * Types used in core-to-core passes FloatOutSwitches(..), - pprPassDetails, - -- * Plugins - CorePluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), - -- * The monad CoreM, runCoreM, + mapDynFlagsCoreM, dropSimplCount, + -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, + getHscEnv, getModule, + initRuleEnv, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, - getVisibleOrphanMods, getUniqMask, - getPrintUnqualified, getSrcSpanM, + getInteractiveContext, + getUniqMask, + getNamePprCtx, getSrcSpanM, -- ** Writing to the monad addSimplCount, @@ -42,7 +33,7 @@ getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, msg, + putMsg, putMsgS, errorMsg, msg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -52,12 +43,10 @@ import GHC.Driver.Session import GHC.Driver.Env -import GHC.Core -import GHC.Core.Unfold +import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) +import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) -import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations -import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc @@ -68,141 +57,22 @@ import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Data.FastString import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) import qualified GHC.Data.IOEnv as IOEnv +import GHC.Runtime.Context ( InteractiveContext ) + import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Unit.External import Data.Bifunctor ( bimap ) -import Data.List (intersperse, groupBy, sortBy) -import Data.Ord import Data.Dynamic -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict +import Data.Maybe (listToMaybe) import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) -import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplMode - | CoreDoPluginPass String CorePluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoExitify - | CoreDoDemand - | CoreDoCpr - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreAddCallerCcs - | CoreAddLateCcs - | CoreOccurAnal - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoDemand = text "Demand analysis" - ppr CoreDoCpr = text "Constructed Product Result analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CoreAddCallerCcs = text "Add caller cost-centres" - ppr CoreAddLateCcs = text "Add late core cost-centres" - ppr CorePrep = text "CorePrep" - ppr CoreOccurAnal = text "Occurrence analysis" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] -pprPassDetails _ = Outputable.empty - -data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - = SimplMode - { sm_names :: [String] -- ^ Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_logger :: !Logger - , sm_dflags :: DynFlags - -- Just for convenient non-monadic access; we don't override these. - -- - -- Used for: - -- - target platform (for `exprIsDupable` and `mkDupableAlt`) - -- - Opt_DictsCheap and Opt_PedanticBottoms general flags - -- - rules options (initRuleOpts) - -- - inlineCheck - } - -instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_cast_swizzle = cs - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (text "inline") <> comma - , pp_flag r (text "rules") <> comma - , pp_flag eta (text "eta-expand") <> comma - , pp_flag cs (text "cast-swizzle") <> comma - , pp_flag cc (text "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> s - data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if -- doing so will abstract over n or fewer @@ -232,341 +102,9 @@ , text "Consts =" <+> ppr (floatOutConstants sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - {- - ************************************************************************ * * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type CorePluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = getPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount lhs rhs = - throwGhcException . PprProgramError "plusSimplCount" $ vcat - [ text "lhs" - , pprSimplCount lhs - , text "rhs" - , pprSimplCount rhs - ] - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -{- Note [Which transformations are innocuous] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point (Jun 18) I wondered if some transformations (ticks) -might be "innocuous", in the sense that they do not unlock a later -transformation that does not occur in the same pass. If so, we could -refrain from bumping the overall tick-count for such innocuous -transformations, and perhaps terminate the simplifier one pass -earlier. - -But alas I found that virtually nothing was innocuous! This Note -just records what I learned, in case anyone wants to try again. - -These transformations are not innocuous: - -*** NB: I think these ones could be made innocuous - EtaExpansion - LetFloatFromLet - -LetFloatFromLet - x = K (let z = e2 in Just z) - prepareRhs transforms to - x2 = let z=e2 in Just z - x = K xs - And now more let-floating can happen in the - next pass, on x2 - -PreInlineUnconditionally - Example in spectral/cichelli/Auxil - hinsert = ...let lo = e in - let j = ...lo... in - case x of - False -> () - True -> case lo of I# lo' -> - ...j... - When we PreInlineUnconditionally j, lo's occ-info changes to once, - so it can be PreInlineUnconditionally in the next pass, and a - cascade of further things can happen. - -PostInlineUnconditionally - let x = e in - let y = ...x.. in - case .. of { A -> ...x...y... - B -> ...x...y... } - Current postinlineUnconditinaly will inline y, and then x; sigh. - - But PostInlineUnconditionally might also unlock subsequent - transformations for the same reason as PreInlineUnconditionally, - so it's probably not innocuous anyway. - -KnownBranch, BetaReduction: - May drop chunks of code, and thereby enable PreInlineUnconditionally - for some let-binding which now occurs once - -EtaExpansion: - Example in imaginary/digits-of-e1 - fail = \void. e where e :: IO () - --> etaExpandRhs - fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) - --> Next iteration of simplify - fail1 = \void. \s. (e |> g) s - fail = fail1 |> Void# -> sym g - And now inline 'fail' - -CaseMerge: - case x of y { - DEFAULT -> case y of z { pi -> ei } - alts2 } - ---> CaseMerge - case x of { pi -> let z = y in ei - ; alts2 } - The "let z=y" case-binder-swap gets dealt with in the next pass --} - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a common tag - -- toList returns common tags adjacent - groups = groupBy same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick -- See Note [Which transformations are innocuous] - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - -{- -************************************************************************ -* * Monad and carried data structure definitions * * ************************************************************************ @@ -574,12 +112,11 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, + cr_rule_base :: RuleBase, -- Home package table rules cr_module :: Module, - cr_print_unqual :: PrintUnqualified, + cr_name_ppr_ctx :: NamePprCtx, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet, cr_uniq_mask :: !Char -- Mask for creating unique values } @@ -590,9 +127,10 @@ cw_simpl_count :: SimplCount } -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags +emptyWriter :: Bool -- ^ -ddump-simpl-stats + -> CoreWriter +emptyWriter dump_simpl_stats = CoreWriter { + cw_simpl_count = zeroSimplCount dump_simpl_stats } plusWriter :: CoreWriter -> CoreWriter -> CoreWriter @@ -640,20 +178,18 @@ -> RuleBase -> Char -- ^ Mask -> Module - -> ModuleSet - -> PrintUnqualified + -> NamePprCtx -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m +runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_visible_orphan_mods = orph_imps, - cr_print_unqual = print_unqual, + cr_name_ppr_ctx = name_ppr_ctx, cr_loc = loc, cr_uniq_mask = mask } @@ -671,8 +207,8 @@ nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do - r <- getEnv - return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + logger <- hsc_logger . cr_hsc_env <$> getEnv + return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats) read :: (CoreReader -> a) -> CoreM a read f = CoreM $ getEnv >>= (\r -> nop (f r)) @@ -704,15 +240,21 @@ getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base +getHomeRuleBase :: CoreM RuleBase +getHomeRuleBase = read cr_rule_base -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods +initRuleEnv :: ModGuts -> CoreM RuleEnv +initRuleEnv guts + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; return (mkRuleEnv guts eps_rules hpt_rules) } -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual +getExternalRuleBase :: CoreM RuleBase +getExternalRuleBase = eps_rule_base <$> get_eps +getNamePprCtx :: CoreM NamePprCtx +getNamePprCtx = read cr_name_ppr_ctx + getSrcSpanM :: CoreM SrcSpan getSrcSpanM = read cr_loc @@ -724,6 +266,20 @@ -- Convenience accessors for useful fields of HscEnv +-- | Adjust the dyn flags passed to the argument action +mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a +mapDynFlagsCoreM f m = CoreM $ do + !e <- getEnv + let !e' = e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e } + liftIO $ runIOEnv e' $! unCoreM m + +-- | Drop the single count of the argument action so it doesn't effect +-- the total. +dropSimplCount :: CoreM a -> CoreM a +dropSimplCount m = CoreM $ do + (a, _) <- unCoreM m + unCoreM $ pure a + instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv @@ -733,11 +289,16 @@ instance HasModule CoreM where getModule = read cr_module +getInteractiveContext :: CoreM InteractiveContext +getInteractiveContext = hsc_IC <$> getHscEnv + getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do +getPackageFamInstEnv = eps_fam_inst_env <$> get_eps + +get_eps :: CoreM ExternalPackageState +get_eps = do hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps + liftIO $ hscEPS hsc_env {- ************************************************************************ @@ -766,8 +327,8 @@ getFirstAnnotations deserialize guts = bimap mod name <$> getAnnotations deserialize guts where - mod = mapModuleEnv head . filterModuleEnv (const $ not . null) - name = mapNameEnv head . filterNameEnv (not . null) + mod = mapMaybeModuleEnv (const listToMaybe) + name = mapMaybeNameEnv listToMaybe {- Note [Annotations] @@ -799,14 +360,14 @@ msg msg_class doc = do logger <- getLogger loc <- getSrcSpanM - unqual <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx let sty = case msg_class of - MCDiagnostic _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual + MCDiagnostic _ _ _ -> err_sty + MCDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle name_ppr_ctx + user_sty = mkUserStyle name_ppr_ctx AllTheWay + dump_sty = mkDumpStyle name_ppr_ctx liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen @@ -816,10 +377,6 @@ -- | Output a message to the screen putMsg :: SDoc -> CoreM () putMsg = msg MCInfo - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () diff --git a/compiler/GHC/Core/Opt/Monad.hs-boot b/compiler/GHC/Core/Opt/Monad.hs-boot deleted file mode 100644 --- a/compiler/GHC/Core/Opt/Monad.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- Created this hs-boot file to remove circular dependencies from the use of --- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core --- transformations. --- However GHC.Core.Opt.Monad does much more than defining these, and because Plugins are --- activated in various modules, the imports become circular. To solve this I --- extracted CoreToDo and CoreM into this file. --- I needed to write the whole definition of these types, otherwise it created --- a data-newtype conflict. - -module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where - -import GHC.Prelude - -import GHC.Data.IOEnv ( IOEnv ) - -type CoreIOEnv = IOEnv CoreReader - -data CoreReader - -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -data SimplCount - -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - -instance Monad CoreM - -data CoreToDo diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -19,19 +19,20 @@ module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr, - zapLambdaBndrs + zapLambdaBndrs, scrutBinderSwap_maybe ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - stripTicksTopE, mkTicks ) -import GHC.Core.Opt.Arity ( joinRhsArity ) + mkCastMCo, mkTicks ) +import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion +import GHC.Core.Predicate ( isDictId ) import GHC.Core.Type -import GHC.Core.TyCo.FVs( tyCoVarsOfMCo ) +import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) import GHC.Data.Maybe( isJust, orElse ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) @@ -53,12 +54,13 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Trace import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL, mapAccumR) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -363,6 +365,12 @@ then just glom all the bindings into a single Rec, so that the *next* iteration of the occurrence analyser will sort them all out. This part happens in occurAnalysePgm. + +This is a legitimate situation where the need for glomming doesn't +point to any problems. However, when GHC is compiled with -DDEBUG, we +produce a warning addressed to the GHC developers just in case we +require glomming due to an out-of-order reference that is caused by +some earlier transformation stage misbehaving. -} {- @@ -613,7 +621,7 @@ j2 as a join point. So we must do the adjustRhsUsage thing on j's RHS. That's why we pass mb_join_arity to calcUnfolding. -Aame with rules. Suppose we have: +Same with rules. Suppose we have: let j :: Int -> Int j y = 2 * y @@ -625,7 +633,7 @@ We identify k as a join point, and we want j to be a join point too. Without the RULE it would be, and we don't want the RULE to mess it up. So provided the join-point arity of k matches the args of the -rule we can allow the tail-cal info from the RHS of the rule to +rule we can allow the tail-call info from the RHS of the rule to propagate. * Wrinkle for Rec case. In the recursive case we don't know the @@ -782,7 +790,7 @@ -- h = ... -- g = ... -- RULE map g = h - -- Then we want to ensure that h is in scope everwhere + -- Then we want to ensure that h is in scope everywhere -- that g is (since the RULE might turn g into h), so -- we make g mention h. @@ -952,7 +960,7 @@ (which occurs just once), but because it is last we won't actually substitute in lvl2. Sigh. -To avoid this possiblity, we include edges from lvl2 to /both/ its +To avoid this possibility, we include edges from lvl2 to /both/ its stable unfolding /and/ its RHS. Hence the defn of inl_fvs in makeNode. Maybe we could be more clever, but it's very much a corner case. @@ -1216,7 +1224,7 @@ $s$dm2 = \x. op dBool } The RULES stuff means that we can't choose $dm as a loop breaker (Note [Choosing loop breakers]), so we must choose at least (say) -opInt *and* opBool, and so on. The number of loop breakders is +opInt *and* opBool, and so on. The number of loop breakers is linear in the number of instance declarations. Note [Loop breakers and INLINE/INLINABLE pragmas] @@ -1749,7 +1757,7 @@ * Why do we take care to account for intervening casts? Answer: currently we don't do eta-expansion and cast-swizzling in a stable - unfolding (see Note [Eta-expansion in stable unfoldings]). + unfolding (see Historical-note [Eta-expansion in stable unfoldings]). So we can get f = \x. ((\y. ...x...y...) |> co) Now, since the lambdas aren't together, the occurrence analyser will @@ -1851,7 +1859,8 @@ -- usage3: you might think this was not necessary, because of -- the markAllNonTail in adjustRhsUsage; but not so! For a -- join point, adjustRhsUsage doesn't do this; yet if there is - -- a cast, we must! + -- a cast, we must! Also: why markAllNonTail? See + -- GHC.Core.Lint: Note Note [Join points and casts] usage3 = markAllNonTail usage2 in WithUsageDetails usage3 (Cast expr' co) @@ -1861,7 +1870,7 @@ {- Note [Occ-anal and cast worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider y = e; x = y |> co -If we mark y as used-once, we'll inline y into x, and the the Cast +If we mark y as used-once, we'll inline y into x, and the Cast worker/wrapper transform will float it straight back out again. See Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify. @@ -2362,7 +2371,7 @@ f's strictness signature into e1 .. en, but /only/ if n is enough to saturate the strictness signature. A strictness signature like - f :: C1(C1(L))LS + f :: C(1,C(1,L))LS means that *if f is applied to three arguments* then it will guarantee to call its first argument at most once, and to call the result of that at @@ -2398,10 +2407,10 @@ B: Let-bindings: eg let f = \c. let ... in \n -> blah in (build f, build f) - Propagate one-shot info from the demanand-info on 'f' to the + Propagate one-shot info from the demand-info on 'f' to the lambdas in its RHS (which may not be syntactically at the top) - This information must have come from a previous run of the demanand + This information must have come from a previous run of the demand analyser. Previously, the demand analyser would *also* set the one-shot information, but @@ -2456,9 +2465,9 @@ -- See Note [The binder-swap substitution] -- If x :-> (y, co) is in the env, - -- then please replace x by (y |> sym mco) - -- Invariant of course: idType x = exprType (y |> sym mco) - , occ_bs_env :: !(VarEnv (OutId, MCoercion)) + -- then please replace x by (y |> mco) + -- Invariant of course: idType x = exprType (y |> mco) + , occ_bs_env :: !(IdEnv (OutId, MCoercion)) -- Domain is Global and Local Ids -- Range is just Local Ids , occ_bs_rng :: !VarSet @@ -2665,7 +2674,7 @@ There are two main pieces: * Given case x |> co of b { alts } - we add [x :-> (b, co)] to the occ_bs_env environment; this is + we add [x :-> (b, sym co)] to the occ_bs_env environment; this is done by addBndrSwap. * Then, at an occurrence of a variable, we look up in the occ_bs_env @@ -2737,30 +2746,8 @@ (BS5) We have to apply the occ_bs_env substitution uniformly, including to (local) rules and unfoldings. -Historical note ---------------- -We used to do the binder-swap transformation by introducing -a proxy let-binding, thus; - - case x of b { pi -> ri } - ==> - case x of b { pi -> let x = b in ri } - -But that had two problems: - -1. If 'x' is an imported GlobalId, we'd end up with a GlobalId - on the LHS of a let-binding which isn't allowed. We worked - around this for a while by "localising" x, but it turned - out to be very painful #16296, - -2. In CorePrep we use the occurrence analyser to do dead-code - elimination (see Note [Dead code in CorePrep]). But that - occasionally led to an unlifted let-binding - case x of b { DEFAULT -> let x::Int# = b in ... } - which disobeys one of CorePrep's output invariants (no unlifted - let-bindings) -- see #5433. - -Doing a substitution (via occ_bs_env) is much better. +(BS6) We must be very careful with dictionaries. + See Note [Care with binder-swap on dictionaries] Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ @@ -2770,6 +2757,54 @@ equation (2) in Note [Binder swap]. When we get to the inner case, we inline x, cancel the casts, and away we go. +Note [Care with binder-swap on dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note explains why we need isDictId in scrutBinderSwap_maybe. +Consider this tricky example (#21229, #21470): + + class Sing (b :: Bool) where sing :: Bool + instance Sing 'True where sing = True + instance Sing 'False where sing = False + + f :: forall a. Sing a => blah + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a dSing + +Now do a binder-swap on the case-expression: + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (wild |> sym the_co) + +And now substitute `False` for `wild` (since wild=False in the False branch): + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (False |> sym the_co) + +And now we have a problem. The specialiser will specialise (f @a d)a (for all +vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using +Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise. + +The real problem is the binder-swap. It swaps a dictionary variable $dSing +(of kind Constraint) for a term variable wild (of kind Type). And that is +dangerous: a dictionary is a /singleton/ type whereas a general term variable is +not. In this particular example, Bool is most certainly not a singleton type! + +Conclusion: + for a /dictionary variable/ do not perform + the clever cast version of the binder-swap + +Hence the subtle isDictId in scrutBinderSwap_maybe. + Note [Zap case binders in proxy bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ From the original @@ -2784,8 +2819,87 @@ NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. +-} + +addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [The binder-swap substitution] +addBndrSwap scrut case_bndr + env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) + | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut + , scrut_var /= case_bndr + -- Consider: case x of x { ... } + -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + , occ_bs_rng = rng_vars `extendVarSet` case_bndr' + `unionVarSet` tyCoVarsOfMCo mco } + + | otherwise + = env + where + case_bndr' = zapIdOccInfo case_bndr + -- See Note [Zap case binders in proxy bindings] + +scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion) +-- If (scrutBinderSwap_maybe e = Just (v, mco), then +-- v = e |> mco +-- See Note [Case of cast] +-- See Note [Care with binder-swap on dictionaries] +-- +-- We use this same function in SpecConstr, and Simplify.Iteration, +-- when something binder-swap-like is happening +scrutBinderSwap_maybe (Var v) = Just (v, MRefl) +scrutBinderSwap_maybe (Cast (Var v) co) + | not (isDictId v) = Just (v, MCo (mkSymCo co)) + -- Cast: see Note [Case of cast] + -- isDictId: see Note [Care with binder-swap on dictionaries] + -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps + -- over-conservatively. But I have never seen one, so I'm leaving + -- the code as simple as possible. Losing the binder-swap in a + -- rare case probably has very low impact. +scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e -- Drop ticks +scrutBinderSwap_maybe _ = Nothing + +lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) +-- See Note [The binder-swap substitution] +-- Returns an expression of the same type as Id +lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr + = case lookupVarEnv bs_env bndr of { + Nothing -> (Var bndr, bndr) ; + Just (bndr1, mco) -> + + -- Why do we iterate here? + -- See (BS2) in Note [The binder-swap substitution] + case lookupBndrSwap env bndr1 of + (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } + + +{- Historical note [Proxy let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to do the binder-swap transformation by introducing +a proxy let-binding, thus; + + case x of b { pi -> ri } + ==> + case x of b { pi -> let x = b in ri } + +But that had two problems: + +1. If 'x' is an imported GlobalId, we'd end up with a GlobalId + on the LHS of a let-binding which isn't allowed. We worked + around this for a while by "localising" x, but it turned + out to be very painful #16296, + +2. In CorePrep we use the occurrence analyser to do dead-code + elimination (see Note [Dead code in CorePrep]). But that + occasionally led to an unlifted let-binding + case x of b { DEFAULT -> let x::Int# = b in ... } + which disobeys one of CorePrep's output invariants (no unlifted + let-bindings) -- see #5433. + +Doing a substitution (via occ_bs_env) is much better. + Historical Note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We *used* to suppress the binder-swap in case expressions when -fno-case-of-case is on. Old remarks: "This happens in the first simplifier pass, @@ -2844,53 +2958,8 @@ It's fixed by doing the binder-swap in OccAnal because we can do the binder-swap unconditionally and still get occurrence analysis information right. --} -addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv --- See Note [The binder-swap substitution] -addBndrSwap scrut case_bndr - env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) - | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut) - , scrut_var /= case_bndr - -- Consider: case x of x { ... } - -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop - = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) - , occ_bs_rng = rng_vars `extendVarSet` case_bndr' - `unionVarSet` tyCoVarsOfMCo mco } - | otherwise - = env - where - get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion) - get_scrut_var (Var v) = Just (v, MRefl) - get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast] - get_scrut_var _ = Nothing - - case_bndr' = zapIdOccInfo case_bndr - -- See Note [Zap case binders in proxy bindings] - -lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) --- See Note [The binder-swap substitution] --- Returns an expression of the same type as Id -lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr - = case lookupVarEnv bs_env bndr of { - Nothing -> (Var bndr, bndr) ; - Just (bndr1, mco) -> - - -- Why do we iterate here? - -- See (BS2) in Note [The binder-swap substitution] - case lookupBndrSwap env bndr1 of - (fun, fun_id) -> (add_cast fun mco, fun_id) } - - where - add_cast fun MRefl = fun - add_cast fun (MCo co) = Cast fun (mkSymCo co) - -- We must switch that 'co' to 'sym co'; - -- see the comment with occ_bs_env - -- No need to test for isReflCo, because 'co' came from - -- a (Cast e co) and hence is unlikely to be Refl - -{- ************************************************************************ * * \subsection[OccurAnal-types]{OccEnv} @@ -3129,7 +3198,7 @@ tagNonRecBinder lvl usage binder = let occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl usage [binder] + will_be_join = decideJoinPointHood lvl usage (NE.singleton binder) occ' | will_be_join = -- must already be marked AlwaysTailCalled assert (isAlwaysTailCalled occ) occ | otherwise = markNonTail occ @@ -3154,8 +3223,12 @@ -- 1. Determine join-point-hood of whole group, as determined by -- the *unadjusted* usage details unadj_uds = foldr andUDs body_uds rhs_udss - will_be_joins = decideJoinPointHood lvl unadj_uds bndrs + -- This is only used in `mb_join_arity`, to adjust each `Details` in `details_s`, thus, + -- when `bndrs` is non-empty. So, we only write `maybe False` as `decideJoinPointHood` + -- takes a `NonEmpty CoreBndr`; the default value `False` won't affect program behavior. + will_be_joins = maybe False (decideJoinPointHood lvl unadj_uds) (nonEmpty bndrs) + -- 2. Adjust usage details of each RHS, taking into account the -- join-point-hood decision rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds @@ -3210,12 +3283,12 @@ -- -- See Note [Invariants on join points] in "GHC.Core". decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] + -> NonEmpty CoreBndr -> Bool decideJoinPointHood TopLevel _ _ = False decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (head bndrs) + | isJoinId (NE.head bndrs) = warnPprTrace (not all_ok) "OccurAnal failed to rediscover join point(s)" (ppr bndrs) all_ok diff --git a/compiler/GHC/Core/Opt/Pipeline/Types.hs b/compiler/GHC/Core/Opt/Pipeline/Types.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Pipeline/Types.hs @@ -0,0 +1,103 @@ +module GHC.Core.Opt.Pipeline.Types ( + -- * Configuration of the core-to-core passes + CorePluginPass, CoreToDo(..), + bindsOnlyPass, pprPassDetails, + ) where + +import GHC.Prelude + +import GHC.Core ( CoreProgram ) +import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Utils.Outputable as Outputable + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify !SimplifyOpts + -- ^ The core-to-core simplifier. + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand Bool -- Bool: Do worker/wrapper afterwards? + -- See Note [Don't change boxity without worker/wrapper] + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreAddCallerCcs + | CoreAddLateCcs + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr (CoreDoDemand True) = text "Demand analysis (including Boxity)" + ppr (CoreDoDemand False) = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CoreAddCallerCcs = text "Add caller cost-centres" + ppr CoreAddLateCcs = text "Add late core cost-centres" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n + , ppr md ] + where + n = so_iterations cfg + md = so_mode cfg + +pprPassDetails _ = Outputable.empty diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify + ( SimplifyExprOpts(..), SimplifyOpts(..) + , simplifyExpr, simplifyPgm + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Rules +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Utils ( mkTicks, stripTicksTop ) +import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) +import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) +import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Stats ( simplCountN ) +import GHC.Core.FamInstEnv + +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) + +import GHC.Unit.Env ( UnitEnv, ueEPS ) +import GHC.Unit.External +import GHC.Unit.Module.ModGuts + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Tickish +import GHC.Types.Unique.FM + +import Control.Monad +import Data.Foldable ( for_ ) + +#if __GLASGOW_HASKELL__ <= 810 +import GHC.Utils.Panic ( panic ) +#endif + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyExpr`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyExprOpts = SimplifyExprOpts + { se_fam_inst :: ![FamInst] + , se_mode :: !SimplMode + , se_top_env_cfg :: !TopEnvConfig + } + +simplifyExpr :: Logger + -> ExternalUnitCache + -> SimplifyExprOpts + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr logger euc opts expr + = withTiming logger (text "Simplify [expr]") (const ()) $ + do { eps <- eucEPS euc ; + ; let fam_envs = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts + ) + simpl_env = mkSimplEnv (se_mode opts) fam_envs + top_env_cfg = se_top_env_cfg opts + read_eps_rules = eps_rule_base <$> eucEPS euc + read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules + + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ + simplExprGently simpl_env expr + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplify rule LHS] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyPgm`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyOpts = SimplifyOpts + { so_dump_core_sizes :: !Bool + , so_iterations :: !Int + , so_mode :: !SimplMode + + , so_pass_result_cfg :: !(Maybe LintPassResultConfig) + -- Nothing => Do not Lint + -- Just cfg => Lint like this + + , so_hpt_rules :: !RuleBase + , so_top_env_cfg :: !TopEnvConfig + } + +simplifyPgm :: Logger + -> UnitEnv + -> NamePprCtx -- For dumping + -> SimplifyOpts + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgm logger unit_env name_ppr_ctx opts + guts@(ModGuts { mg_module = this_mod + , mg_binds = binds, mg_rules = local_rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration 1 [] binds local_rules + + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dump_core_sizes = so_dump_core_sizes opts + mode = so_mode opts + max_iterations = so_iterations opts + top_env_cfg = so_top_env_cfg opts + active_rule = activeRule mode + active_unf = activeUnfolding mode + -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` + -- the old bindings are retained until the end of all simplifier iterations + !guts_no_binds = guts { mg_binds = [], mg_rules = [] } + + hpt_rule_env :: RuleEnv + hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts) + -- emptyRuleBase: no EPS rules yet; we will update + -- them on each iteration to pick up the most up to date set + + do_iteration :: Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings + -> [CoreRule] -- Local rules for imported Ids + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration iteration_no counts_so_far binds local_rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = warnPprTrace (debugIsOn && (max_iterations > 2)) + "Simplifier bailing out" + ( hang (ppr this_mod <> text ", after" + <+> int max_iterations <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule + local_rules binds + } ; + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- read_eps_rules: + -- We need to read rules from the EPS regularly because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + -- Hence just before attempting to match a rule we read the EPS + -- value (via read_rule_env) and then combine it with the existing rule base. + -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. + eps <- ueEPS unit_env ; + let { -- base_rule_env contains + -- (a) home package rules, fixed across all iterations + -- (b) local rules (substituted) from `local_rules` arg to do_iteration + -- Forcing base_rule_env to avoid unnecessary allocations. + -- Not doing so results in +25.6% allocations of LargeRecord. + ; !base_rule_env = updLocalRules hpt_rule_env local_rules + + ; read_eps_rules :: IO PackageRuleBase + ; read_eps_rules = eps_rule_base <$> ueEPS unit_env + + ; read_rule_env :: IO RuleEnv + ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules + + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; simpl_env = mkSimplEnv mode fam_envs } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl logger read_rule_env top_env_cfg sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplImpRules env1 local_rules + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ; + + for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> + lintPassResult logger pass_result_cfg binds2 ; + + -- Loop + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "do_iteration" +#endif + where + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + +dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules + = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules + where + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> text hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +they say. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds + where + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's RULES] + else warnPprTrace True "Not shorting out" (ppr exported_id) False + else + False + +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's RULES] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (realUnfoldingInfo info)) + where + info = idInfo id + +{- Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + lcl_id = e; exp_id = lcl_id + +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id + +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma + +Overwriting, rather than merging, seems to work ok. + +For the lcl_id we + +* Zap the InlinePragma. It might originally have had a NOINLINE, which + we have now transferred; and we really want the lcl_id to inline now + that its RHS is trivial! + +* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, + replacing lcl_id by gbl_id. That won't happen if lcl_id has its original + great big Stable unfolding +-} + +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , modifyIdInfo zap_info local_id ) + where + local_info = idInfo local_id + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info + `setUnfoldingInfo` realUnfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another + + zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma + `setUnfoldingInfo` noUnfolding diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -0,0 +1,1266 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + + + +module GHC.Core.Opt.Simplify.Env ( + -- * The simplifier mode + SimplMode(..), updMode, + smPedanticBottoms, smPlatform, + + -- * Environments + SimplEnv(..), pprSimplEnv, -- Temp not abstract + seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, + seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, + seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seRuleOpts, seRules, seUnfoldingOpts, + mkSimplEnv, extendIdSubst, + extendTvSubst, extendCvSubst, + zapSubstEnv, setSubstEnv, bumpCaseDepth, + getInScope, setInScopeFromE, setInScopeFromF, + setInScopeSet, modifyInScope, addNewInScopeIds, + getSimplRules, enterRecGroupRHSs, + + -- * Substitution results + SimplSR(..), mkContEx, substId, lookupRecBndr, + + -- * Simplifying 'Id' binders + simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, + simplBinder, simplBinders, + substTy, substTyVar, getSubst, + substCo, substCoVar, + + -- * Floats + SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats, + mkFloatBind, addLetFloats, addJoinFloats, addFloats, + extendFloats, wrapFloats, + isEmptyJoinFloats, isEmptyLetFloats, + doFloatFromRhs, getTopFloatBinds, + + -- * LetFloats + LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat, + addLetFlts, mapLetFloats, + + -- * JoinFloats + JoinFloat, JoinFloats, emptyJoinFloats, + wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts + ) where + +import GHC.Prelude + +import GHC.Core.Coercion.Opt ( OptCoercionOpts ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core.Opt.Arity ( ArityOpts(..) ) +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Rules.Config ( RuleOpts(..) ) +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Multiplicity ( scaleScaled ) +import GHC.Core.Unfold +import GHC.Core.TyCo.Subst (emptyIdSubstEnv) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Data.OrdList +import GHC.Data.Graph.UnVar +import GHC.Types.Id as Id +import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) +import GHC.Builtin.Types +import qualified GHC.Core.Type as Type +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo + , extendTvSubst, extendCvSubst ) +import qualified GHC.Core.Coercion as Coercion +import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Platform ( Platform ) +import GHC.Types.Basic +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc +import GHC.Types.Unique.FM ( pprUniqFM ) + +import Data.List ( intersperse, mapAccumL ) + +{- +************************************************************************ +* * +\subsubsection{The @SimplEnv@ type} +* * +************************************************************************ +-} + +{- +Note [The environments of the Simplify pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions of the Simplify pass draw their contextual data from two +environments: `SimplEnv`, which is passed to the functions as an argument, and +`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist +corresponding configuration records `SimplMode` and `TopEnvConfig` respectively. +A configuration record denotes a unary datatype bundeling the various options +and switches we provide to control the behaviour of the respective part of the +Simplify pass. The value is provided by the driver using the functions found in +the GHC.Driver.Config.Core.Opt.Simplify module. + +These configuration records are part in the environment to avoid needless +copying of their values. This raises the question which data value goes in which +of the four datatypes. For each value needed by the pass we ask the following +two questions: + + * Does the value only make sense in a monadic environment? + + * Is it part of the configuration of the pass and provided by the user or is it + it an internal value? + +Examples of values that make only sense in conjunction with `SimplM` are the +logger and the values related to counting. As it does not make sense to use them +in a pure function (the logger needs IO and counting needs access to the +accumulated counts in the monad) we want these to live in `SimplTopEnv`. +Other values, like the switches controlling the behaviour of the pass (e.g. +whether to do case merging or not) are perfectly usable in a non-monadic setting. +Indeed many of those are used in guard expressions and it would be cumbersome to +query them from the monadic environment and feed them to the pure functions as +an argument. Hence we conveniently store them in the `SpecEnv` environment which +can be passed to pure functions as a whole. + +Now that we know in which of the two environments a particular value lives we +turn to the second question to determine if the value is part of the +configuration record embedded in the environment or if it is stored in an own +field in the environment type. Some values like the tick factor must be provided +from outside as we can neither derive it from other values provided to us nor +does a constant value make sense. Other values like the maximal number of ticks +are computed on environment initialization and we wish not to expose the field +to the "user" or the pass -- it is an internal value. Therefore the distinction +here is between "freely set by the caller" and "internally managed by the pass". + +Note that it doesn't matter for the decision procedure wheter a value is altered +throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline, +sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the +definitions of `updModeForStableUnfoldings` and `updModeForRules` in +GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the +caller of the Simplify pass needs to provide the initial values for those fields. + +The decision which value goes into which datatype can be summarized by the +following table: + | Usable in a | + | pure setting | monadic setting | + |----------------------------|--------------|-----------------| + | Set by user | SimplMode | TopEnvConfig | + | Computed on initialization | SimplEnv | SimplTopEnv | + +-} + +data SimplEnv + = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + + -- See Note [The environments of the Simplify pass] + seMode :: !SimplMode + , seFamEnvs :: !(FamInstEnv, FamInstEnv) + + -- The current substitution + , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType + , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion + , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + + -- | Fast OutVarSet tracking which recursive RHSs we are analysing. + -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity. + , seRecIds :: !UnVarSet + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + , seInScope :: !InScopeSet -- OutVars only + + , seCaseDepth :: !Int -- Depth of multi-branch case alternatives + } + +seArityOpts :: SimplEnv -> ArityOpts +seArityOpts env = sm_arity_opts (seMode env) + +seCaseCase :: SimplEnv -> Bool +seCaseCase env = sm_case_case (seMode env) + +seCaseFolding :: SimplEnv -> Bool +seCaseFolding env = sm_case_folding (seMode env) + +seCaseMerge :: SimplEnv -> Bool +seCaseMerge env = sm_case_merge (seMode env) + +seCastSwizzle :: SimplEnv -> Bool +seCastSwizzle env = sm_cast_swizzle (seMode env) + +seDoEtaReduction :: SimplEnv -> Bool +seDoEtaReduction env = sm_do_eta_reduction (seMode env) + +seEtaExpand :: SimplEnv -> Bool +seEtaExpand env = sm_eta_expand (seMode env) + +seFloatEnable :: SimplEnv -> FloatEnable +seFloatEnable env = sm_float_enable (seMode env) + +seInline :: SimplEnv -> Bool +seInline env = sm_inline (seMode env) + +seNames :: SimplEnv -> [String] +seNames env = sm_names (seMode env) + +seOptCoercionOpts :: SimplEnv -> OptCoercionOpts +seOptCoercionOpts env = sm_co_opt_opts (seMode env) + +sePedanticBottoms :: SimplEnv -> Bool +sePedanticBottoms env = smPedanticBottoms (seMode env) + +sePhase :: SimplEnv -> CompilerPhase +sePhase env = sm_phase (seMode env) + +sePlatform :: SimplEnv -> Platform +sePlatform env = smPlatform (seMode env) + +sePreInline :: SimplEnv -> Bool +sePreInline env = sm_pre_inline (seMode env) + +seRuleOpts :: SimplEnv -> RuleOpts +seRuleOpts env = sm_rule_opts (seMode env) + +seRules :: SimplEnv -> Bool +seRules env = sm_rules (seMode env) + +seUnfoldingOpts :: SimplEnv -> UnfoldingOpts +seUnfoldingOpts env = sm_uf_opts (seMode env) + +-- See Note [The environments of the Simplify pass] +data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + , sm_do_eta_reduction :: !Bool + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p , sm_names = ss + , sm_rules = r, sm_inline = i + , sm_cast_swizzle = cs + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (text "inline") <> comma + , pp_flag r (text "rules") <> comma + , pp_flag eta (text "eta-expand") <> comma + , pp_flag cs (text "cast-swizzle") <> comma + , pp_flag cc (text "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> s + +smPedanticBottoms :: SimplMode -> Bool +smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) + +smPlatform :: SimplMode -> Platform +smPlatform opts = roPlatform (sm_rule_opts opts) + +data FloatEnable -- Controls local let-floating + = FloatDisabled -- Do no local let-floating + | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only + | FloatEnabled -- Do local let-floating on all bindings + +{- +Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~ +The Simplifier can perform local let-floating: it floats let-bindings +out of the RHS of let-bindings. See + Let-floating: moving bindings to give faster programs (ICFP'96) + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + +Here's an example + x = let y = v+1 in (y,true) + +The RHS of x is a thunk. Much better to float that y-binding out to give + y = v+1 + x = (y,true) + +Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in +the scope of the x-binding can now be simplified. + +This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, +controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. + +The `FloatEnable` data type controls where local let-floating takes place; +it allows you to specify that it should be done only for nested bindings; +or for top-level bindings as well; or not at all. + +Note that all of this is quite separate from the global FloatOut pass; +see GHC.Core.Opt.FloatOut. + +-} + +data SimplFloats + = SimplFloats + { -- Ordinary let bindings + sfLetFloats :: LetFloats + -- See Note [LetFloats] + + -- Join points + , sfJoinFloats :: JoinFloats + -- Handled separately; they don't go very far + -- We consider these to be /inside/ sfLetFloats + -- because join points can refer to ordinary bindings, + -- but not vice versa + + -- Includes all variables bound by sfLetFloats and + -- sfJoinFloats, plus at least whatever is in scope where + -- these bindings land up. + , sfInScope :: InScopeSet -- All OutVars + } + +instance Outputable SimplFloats where + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + = text "SimplFloats" + <+> braces (vcat [ text "lets: " <+> ppr lf + , text "joins:" <+> ppr jf + , text "in_scope:" <+> ppr is ]) + +emptyFloats :: SimplEnv -> SimplFloats +emptyFloats env + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = emptyJoinFloats + , sfInScope = seInScope env } + +isEmptyFloats :: SimplFloats -> Bool +-- Precondition: used only when sfJoinFloats is empty +isEmptyFloats (SimplFloats { sfLetFloats = LetFloats fs _ + , sfJoinFloats = js }) + = assertPpr (isNilOL js) (ppr js ) $ + isNilOL fs + +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> id_subst_doc, + text "InScope:" <+> in_scope_vars_doc + ] + where + id_subst_doc = pprUniqFM ppr (seIdSubst env) + in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) + (vcat . map ppr_one) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst + +-- | A substitution result. +data SimplSR + = DoneEx OutExpr (Maybe JoinArity) + -- If x :-> DoneEx e ja is in the SimplIdSubst + -- then replace occurrences of x by e + -- and ja = Just a <=> x is a join-point of arity a + -- See Note [Join arity in SimplIdSubst] + + + | DoneId OutId + -- If x :-> DoneId v is in the SimplIdSubst + -- then replace occurrences of x by v + -- and v is a join-point of arity a + -- <=> x is a join-point of arity a + + | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv + SimplIdSubst + InExpr + -- If x :-> ContEx tv cv id e is in the SimplISubst + -- then replace occurrences of x by (subst (tv,cv,id) e) + +instance Outputable SimplSR where + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e + where + pp_mj = case mj of + Nothing -> empty + Just n -> parens (int n) + + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs + +{- +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences + + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. + + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind + +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds + can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + + Note, though that the substitution isn't necessarily extended + if the type of the Id changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space + leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get + mapped to the full-adorned binder, which is also the one put in the + binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synonyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var + +Note [Join arity in SimplIdSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to remember which incoming variables are join points: the occurrences +may not be marked correctly yet, and we're in change of propagating the change if +OccurAnal makes something a join point). + +Normally the in-scope set is where we keep the latest information, but +the in-scope set tracks only OutVars; if a binding is unconditionally +inlined (via DoneEx), it never makes it into the in-scope set, and we +need to know at the occurrence site that the variable is a join point +so that we know to drop the context. Thus we remember which join +points we're substituting. -} + +mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv +mkSimplEnv mode fam_envs + = SimplEnv { seMode = mode + , seFamEnvs = fam_envs + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv + , seRecIds = emptyUnVarSet + , seCaseDepth = 0 } + -- The top level "enclosing CC" is "SUBSUMED". + +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy unitTy)) + -- See Note [WildCard binders] + +{- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be *occurrences* of wild-id. For example, +GHC.Core.Make.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. +-} + +updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv +updMode upd env + = -- Avoid keeping env alive in case inlining fails. + let mode = upd $! (seMode env) + in env { seMode = mode } + +bumpCaseDepth :: SimplEnv -> SimplEnv +bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 } + +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = assertPpr (isId var && not (isCoVar var)) (ppr var) $ + env { seIdSubst = extendVarEnv subst var res } + +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res + = assertPpr (isTyVar var) (ppr var $$ ppr res) $ + env {seTvSubst = extendVarEnv tsubst var res} + +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co + = assert (isCoVar var) $ + env {seCvSubst = extendVarEnv csubst var co} + +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env + +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} + +setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv +-- See Note [Setting the right in-scope set] +setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } + +setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv +setInScopeFromF env floats = env { seInScope = sfInScope floats } + +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs +-- See Note [Bangs in the Simplifier] + = let !in_scope1 = in_scope `extendInScopeSetList` vs + !id_subst1 = id_subst `delVarEnvList` vs + in + env { seInScope = in_scope1, + seIdSubst = id_subst1 } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- _delete_ it from the substitution when going inside + -- the (\x -> ...)! + +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} + +enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv)) + -> SimplM (r, SimplEnv) +enterRecGroupRHSs env bndrs k = do + --pprTraceM "enterRecGroupRHSs" (ppr bndrs) + (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)} + return (r, env''{seRecIds = seRecIds env}) + +{- Note [Setting the right in-scope set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + \x. (let x = e in b) arg[x] +where the let shadows the lambda. Really this means something like + \x1. (let x2 = e in b) arg[x1] + +- When we capture the 'arg' in an ApplyToVal continuation, we capture + the environment, which says what 'x' is bound to, namely x1 + +- Then that continuation gets pushed under the let + +- Finally we simplify 'arg'. We want + - the static, lexical environment binding x :-> x1 + - the in-scopeset from "here", under the 'let' which includes + both x1 and x2 + +It's important to have the right in-scope set, else we may rename a +variable to one that is already in scope. So we must pick up the +in-scope set from "here", but otherwise use the environment we +captured along with 'arg'. This transfer of in-scope set is done by +setInScopeFromE. +-} + +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} + +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } + +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e + +{- +************************************************************************ +* * +\subsection{LetFloats} +* * +************************************************************************ + +Note [LetFloats] +~~~~~~~~~~~~~~~~ +The LetFloats is a bunch of bindings, classified by a FloatFlag. + +The `FloatFlag` contains summary information about the bindings, see the data +type declaration of `FloatFlag` + +Examples + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + NonRec x# (a /# b) FltCareful -- Might fail; does not satisfy let-can-float invariant + NonRec x# (f y) FltCareful -- Might diverge; does not satisfy let-can-float invariant +-} + +data LetFloats = LetFloats (OrdList OutBind) FloatFlag + -- See Note [LetFloats] + +type JoinFloat = OutBind +type JoinFloats = OrdList JoinFloat + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy *or* + -- consist of a single primitive string literal + -- Hence ok to float to top level, or recursive + -- NB: consequence: all bindings satisfy let-can-float invariant + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + -- NB: consequence: all bindings satisfy let-can-float invariant + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let! + -- NB: some bindings may not satisfy let-can-float + +instance Outputable LetFloats where + ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + + +doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatIntoRhs +doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = floatEnabled lvl fe + && not (isNilOL fs) + && want_to_float + && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs + -- See Note [Float when cheap or expandable] + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind + + -- Whether any floating is allowed by flags. + floatEnabled :: TopLevelFlag -> FloatEnable -> Bool + floatEnabled _ FloatDisabled = False + floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl) + floatEnabled _ FloatEnabled = True + +{- +Note [Float when cheap or expandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float a let from a let if the residual RHS is + a) cheap, such as (\x. blah) + b) expandable, such as (f b) if f is CONLIKE +But there are + - cheap things that are not expandable (eg \x. expensive) + - expandable things that are not cheap (eg (f b) where b is CONLIKE) +so we must take the 'or' of the two. +-} + +emptyLetFloats :: LetFloats +emptyLetFloats = LetFloats nilOL FltLifted + +isEmptyLetFloats :: LetFloats -> Bool +isEmptyLetFloats (LetFloats fs _) = isNilOL fs + +emptyJoinFloats :: JoinFloats +emptyJoinFloats = nilOL + +isEmptyJoinFloats :: JoinFloats -> Bool +isEmptyJoinFloats = isNilOL + +unitLetFloat :: OutBind -> LetFloats +-- This key function constructs a singleton float with the right form +unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ + LetFloats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprIsTickedString rhs = FltLifted + -- String literals can be floated freely. + -- See Note [Core top-level string literals] in GHC.Core. + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = FltCareful + +unitJoinFloat :: OutBind -> JoinFloats +unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $ + unitOL bind + +mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) +-- Make a singleton SimplFloats, and +-- extend the incoming SimplEnv's in-scope set with its binders +-- These binders may already be in the in-scope set, +-- but may have by now been augmented with more IdInfo +mkFloatBind env bind + = (floats, env { seInScope = in_scope' }) + where + floats + | isJoinBind bind + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = unitJoinFloat bind + , sfInScope = in_scope' } + | otherwise + = SimplFloats { sfLetFloats = unitLetFloat bind + , sfJoinFloats = emptyJoinFloats + , sfInScope = in_scope' } + -- See Note [Bangs in the Simplifier] + !in_scope' = seInScope env `extendInScopeSetBind` bind + +extendFloats :: SimplFloats -> OutBind -> SimplFloats +-- Add this binding to the floats, and extend the in-scope env too +extendFloats (SimplFloats { sfLetFloats = floats + , sfJoinFloats = jfloats + , sfInScope = in_scope }) + bind + | isJoinBind bind + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats + , sfJoinFloats = jfloats' } + | otherwise + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats' + , sfJoinFloats = jfloats } + where + in_scope' = in_scope `extendInScopeSetBind` bind + floats' = floats `addLetFlts` unitLetFloat bind + jfloats' = jfloats `addJoinFlts` unitJoinFloat bind + +addLetFloats :: SimplFloats -> LetFloats -> SimplFloats +-- Add the let-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addLetFloats floats let_floats + = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats + , sfInScope = sfInScope floats `extendInScopeFromLF` let_floats } + +extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet +extendInScopeFromLF in_scope (LetFloats binds _) + = foldlOL extendInScopeSetBind in_scope binds + +addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats +addJoinFloats floats join_floats + = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) join_floats } + +addFloats :: SimplFloats -> SimplFloats -> SimplFloats +-- Add both let-floats and join-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) + (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) + = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 + , sfJoinFloats = jf1 `addJoinFlts` jf2 + , sfInScope = in_scope } + +addLetFlts :: LetFloats -> LetFloats -> LetFloats +addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) + = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) + +letFloatBinds :: LetFloats -> [CoreBind] +letFloatBinds (LetFloats bs _) = fromOL bs + +addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats +addJoinFlts = appOL + +mkRecFloats :: SimplFloats -> SimplFloats +-- Flattens the floats into a single Rec group, +-- They must either all be lifted LetFloats or all JoinFloats +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff + , sfJoinFloats = jbs + , sfInScope = in_scope }) + = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $ + SimplFloats { sfLetFloats = floats' + , sfJoinFloats = jfloats' + , sfInScope = in_scope } + where + -- See Note [Bangs in the Simplifier] + !floats' | isNilOL bs = emptyLetFloats + | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + !jfloats' | isNilOL jbs = emptyJoinFloats + | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + +wrapFloats :: SimplFloats -> OutExpr -> OutExpr +-- Wrap the floats around the expression +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag + , sfJoinFloats = jbs }) body + = foldrOL mk_let (wrapJoinFloats jbs body) bs + -- Note: Always safe to put the joins on the inside + -- since the values can't refer to them + where + mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant + | otherwise = Let -- let-can-float invariant hold + +wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloatsX floats body + = ( floats { sfJoinFloats = emptyJoinFloats } + , wrapJoinFloats (sfJoinFloats floats) body ) + +wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloats join_floats body + = foldrOL Let body join_floats + +getTopFloatBinds :: SimplFloats -> [CoreBind] +getTopFloatBinds (SimplFloats { sfLetFloats = lbs + , sfJoinFloats = jbs}) + = assert (isNilOL jbs) $ -- Can't be any top-level join bindings + letFloatBinds lbs + +{-# INLINE mapLetFloats #-} +mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats (LetFloats fs ff) fun + = LetFloats fs1 ff + where + app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' + app (Rec bs) = Rec (strictMap fun bs) + !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier] + +{- +************************************************************************ +* * + Substitution of Vars +* * +************************************************************************ + +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurrence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) +-} + +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refineFromInScope in_scope v) + Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Just res -> res -- DoneEx non-var, or ContEx + + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with better IdInfo. + -- + -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. + +refineFromInScope :: InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refineFromInScope in_scope v + +{- +************************************************************************ +* * +\section{Substituting an Id binder} +* * +************************************************************************ + + +These functions are in the monad only so that they can be made strict via seq. + +Note [Return type for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + (join j :: Char -> Int -> Int) 77 + ( j x = \y. y + ord x ) + (in case v of ) + ( A -> j 'x' ) + ( B -> j 'y' ) + ( C -> ) + +The simplifier pushes the "apply to 77" continuation inwards to give + + join j :: Char -> Int + j x = (\y. y + ord x) 77 + in case v of + A -> j 'x' + B -> j 'y' + C -> 77 + +Notice that the "apply to 77" continuation went into the RHS of the +join point. And that meant that the return type of the join point +changed!! + +That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr +takes a (Just res_ty) argument so that it knows to do the type-changing +thing. + +See also Note [Scaling join point arguments]. +-} + +simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders !env bndrs = mapAccumLM simplBinder env bndrs + +------------- +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder !env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr env bndr + ; seqId id `seq` return (env', id) } + +--------------- +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr !env id + -- See Note [Bangs in the Simplifier] + = do { let (!env1, id1) = substIdBndr env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + -- See Note [Bangs in the Simplifier] + = assert (all (not . isJoinId) ids) $ + do { let (!env1, ids1) = mapAccumL substIdBndr env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to GHC.Core.Subst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped +substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) + +-- Inline to make the (OutId -> OutId) function a known call. +-- This is especially important for `substNonCoVarIdBndr` which +-- passes an identity lambda. +{-# INLINE subst_id_bndr #-} +subst_id_bndr :: SimplEnv + -> InBndr -- Env and binder to transform + -> (OutId -> OutId) -- Adjust the type + -> (SimplEnv, OutBndr) +subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id adjust_type + = assertPpr (not (isCoVar old_id)) (ppr old_id) + (env { seInScope = new_in_scope, + seIdSubst = new_subst }, new_id) + -- It's important that both seInScope and seIdSubst are updated with + -- the new_id, /after/ applying adjust_type. That's why adjust_type + -- is done here. If we did adjust_type in simplJoinBndr (the only + -- place that gives a non-identity adjust_type) we'd have to fiddle + -- afresh with both seInScope and seIdSubst + where + -- See Note [Bangs in the Simplifier] + !id1 = uniqAway in_scope old_id + !id2 = substIdType env id1 + !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + !new_id = adjust_type id3 + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + !new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + + !new_in_scope = in_scope `extendInScopeSet` new_id + +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids + +{- +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from the in_id of a let binding to the +out_id so that its arity is visible in its RHS. Examples: + + * f = \x y. let g = \p q. f (p+q) in Just (...g..g...) + Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a + hard time figuring that out when `f` only has arity 0 in its own RHS. + * f = \x y. ....(f `seq` blah).... + We want to drop the seq. + * f = \x. g (\y. f y) + You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true. + Unfortunately, it is not sound in general to eta-reduce in f's RHS. + Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how + we prevent that. + +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. +-} + + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +simplNonRecJoinBndr :: SimplEnv -> InBndr + -> Mult -> OutType + -> SimplM (SimplEnv, OutBndr) + +-- A non-recursive let binder for a join point; +-- context being pushed inward may change the type +-- See Note [Return type for join points] +simplNonRecJoinBndr env id mult res_ty + = do { let (env1, id1) = simplJoinBndr mult res_ty env id + ; seqId id1 `seq` return (env1, id1) } + +simplRecJoinBndrs :: SimplEnv -> [InBndr] + -> Mult -> OutType + -> SimplM SimplEnv +-- Recursive let binders for join points; +-- context being pushed inward may change types +-- See Note [Return type for join points] +simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty + = assert (all isJoinId ids) $ + do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +simplJoinBndr :: Mult -> OutType + -> SimplEnv -> InBndr + -> (SimplEnv, OutBndr) +simplJoinBndr mult res_ty env id + = subst_id_bndr env id (adjustJoinPointType mult res_ty) + +--------------- +adjustJoinPointType :: Mult + -> Type -- New result type + -> Id -- Old join-point Id + -> Id -- Adjusted join-point Id +-- (adjustJoinPointType mult new_res_ty join_id) does two things: +-- +-- 1. Set the return type of the join_id to new_res_ty +-- See Note [Return type for join points] +-- +-- 2. Adjust the multiplicity of arrows in join_id's type, as +-- directed by 'mult'. See Note [Scaling join point arguments] +-- +-- INVARIANT: If any of the first n binders are foralls, those tyvars +-- cannot appear in the original result type. See isValidJoinPointType. +adjustJoinPointType mult new_res_ty join_id + = assert (isJoinId join_id) $ + setIdType join_id new_join_ty + where + orig_ar = idJoinArity join_id + orig_ty = idType join_id + + new_join_ty = go orig_ar orig_ty :: Type + + go 0 _ = new_res_ty + go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty + = mkPiTy (scale_bndr arg_bndr) $ + go (n-1) res_ty + | otherwise + = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) + + -- See Note [Bangs in the Simplifier] + scale_bndr (Anon t af) = (Anon $! (scaleScaled mult t)) af + scale_bndr b@(Named _) = b + +{- Note [Scaling join point arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a join point which is linear in its variable, in some context E: + +E[join j :: a %1 -> a + j x = x + in case v of + A -> j 'x' + B -> ] + +The simplifier changes to: + +join j :: a %1 -> a + j x = E[x] +in case v of + A -> j 'x' + B -> E[] + +If E uses its argument in a nonlinear way (e.g. a case['Many]), then +this is wrong: the join point has to change its type to a -> a. +Otherwise, we'd get a linearity error. + +See also Note [Return type for join points] and Note [Join points and case-of-case]. +-} + +{- +************************************************************************ +* * + Impedance matching to type substitution +* * +************************************************************************ +-} + +getSubst :: SimplEnv -> Subst +getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env + , seCvSubst = cv_env }) + = mkSubst in_scope tv_env cv_env emptyIdSubstEnv + +substTy :: HasDebugCallStack => SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getSubst env) tv + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env tv + = case Type.substTyVarBndr (getSubst env) tv of + (Subst in_scope' _ tv_env' cv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getSubst env) cv of + (Subst in_scope' _ tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getSubst env) co + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || no_free_vars + = id + | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w + subst = Subst in_scope emptyIdSubstEnv tv_env cv_env + old_ty = idType id + old_w = varMult id diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -0,0 +1,4443 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where + +import GHC.Prelude + +import GHC.Platform + +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 ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Reduction +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) +import GHC.Core.DataCon + ( DataCon, dataConWorkId, dataConRepStrictness + , dataConRepArgTys, isUnboxedTupleDataCon + , StrictnessMark (..) ) +import GHC.Core.Opt.Stats ( Tick(..) ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe + , pushCoTyArg, pushCoValArg, exprIsDeadEnd + , typeArity, arityTypeArity, etaExpandAT ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Multiplicity + +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Demand +import GHC.Types.Unique ( hasKey ) +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var ( isTyCoVar ) +import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) + +import GHC.Data.Maybe ( isNothing, orElse ) +import GHC.Data.FastString +import GHC.Unit.Module ( moduleName ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger +import GHC.Utils.Misc + +import Control.Monad + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Pipeline + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +Note [Bangs in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both SimplFloats and SimplEnv do *not* generally benefit from making +their fields strict. I don't know if this is because of good use of +laziness or unintended side effects like closures capturing more variables +after WW has run. + +But the end result is that we keep these lazy, but force them in some places +where we know it's beneficial to the compiler. + +Similarly environments returned from functions aren't *always* beneficial to +force. In some places they would never be demanded so forcing them early +increases allocation. In other places they almost always get demanded so +it's worthwhile to force them early. + +Would it be better to through every allocation of e.g. SimplEnv and decide +wether or not to make this one strict? Absolutely! Would be a good use of +someones time? Absolutely not! I made these strict that showed up during +a profiled build or which I noticed while looking at core for one reason +or another. + +The result sadly is that we end up with "random" bangs in the simplifier +where we sometimes force e.g. the returned environment from a function and +sometimes we don't for the same function. Depending on the context around +the call. The treatment is also not very consistent. I only added bangs +where I saw it making a difference either in the core or benchmarks. Some +patterns where it would be beneficial aren't convered as a consequence as +I neither have the time to go through all of the core and some cases are +too small to show up in benchmarks. + + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a rewrite rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- See Note [Bangs in the Simplifier] + ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + -- See Note [Bangs in the Simplifier] + ; let !floats1 = float `addFloats` floats + ; return (floats1, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env (BC_Let TopLevel Recursive) pairs + simpl_bind env (NonRec b r) + = do { let bind_cxt = BC_Let TopLevel NonRecursive + ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt + ; simplRecOrTopPair env' bind_cxt b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> BindContext + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 bind_cxt pairs0 + = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 + ; let new_bndrs = map sndOf3 triples + ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> + go env triples + ; return (mkRecFloats rec_floats, env2) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env bind_cxt + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> BindContext + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) + old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | otherwise + = case bind_cxt of + BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ + simplJoinBind env is_rec cont old_bndr new_bndr rhs env + + BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ + simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + +simplTrace :: String -> SDoc -> SimplM a -> SimplM a +simplTrace herald doc thing_inside = do + logger <- getLogger + if logHasDumpFlag logger Opt_D_verbose_core2core + then logTraceMsg logger herald doc thing_inside + else thing_inside + +-------------------------- +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- Not a JoinId + -- The OutId has IdInfo, except arity, unfolding + -- Ids only, no TyVars + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: the OutId is already in the InScopeSet of the incoming 'env' +-- Precondition: not a JoinId +-- Precondition: rhs obeys the let-can-float invariant +-- NOT used for JoinIds +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = assert (isId bndr ) + assertPpr (not (isJoinId bndr)) (ppr bndr) $ + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + is_rec (idDemandInfo bndr) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- ANF-ise a constructor or PAP rhs + ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl is_rec + False -- Not strict; this is simplLazyBind + bndr1 body_floats0 body0 + -- Subtle point: we do not need or want tvs' in the InScope set + -- of body_floats2, so we pass in 'env' not 'body_env'. + -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do + -- more renaming than necessary => extra work (see !7777 and test T16577). + -- Don't need: we wrap tvs' around the RHS anyway. + + ; (rhs_floats, body3) + <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + return (body_floats2, body2) + + else -- Non-empty floats, and non-empty tyvars: do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl + tvs' body_floats2 body2 + ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds + ; return (poly_floats, body3) } + + ; let env' = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env' tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: SimplEnv + -> RecFlag + -> SimplCont + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, + -- unfolding + -> InExpr -> SimplEnv -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } + +-------------------------- +simplNonRecX :: SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of simplNonRec used when the RHS is already +-- simplified, notably in knownCon. It uses case-binding where necessary. +-- +-- Precondition: rhs satisfies the let-can-float invariant + +simplNonRecX env bndr new_rhs + | assertPpr (not (isJoinId bndr)) (ppr bndr) $ + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + | Coercion co <- new_rhs + = return (emptyFloats env, extendCvSubst env bndr co) + + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + -- This case would ultimately land in postInlineUnconditionally + -- but it seems not uncommon, and avoids a lot of faff to do it here + = return (emptyFloats env + , extendIdSubst env bndr (DoneEx new_rhs Nothing)) + + | otherwise + = do { (env1, new_bndr) <- simplBinder env bndr + ; let is_strict = isStrictId new_bndr + -- isStrictId: use new_bndr because the InId bndr might not have + -- a fixed runtime representation, which isStrictId doesn't expect + -- c.f. Note [Dark corner with representation polymorphism] + + ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict + new_bndr (emptyFloats env) new_rhs + -- NB: it makes a surprisingly big difference (5% in compiler allocation + -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', + -- because this is simplNonRecX, so bndr is not in scope in the RHS. + + ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats) + (BC_Let NotTopLevel NonRecursive) + bndr new_bndr rhs1 + -- Must pass env1 to completeBind in case simplBinder had to clone, + -- and extended the substitution with [bndr :-> new_bndr] + + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + Cast worker/wrapper +* * +************************************************************************ + +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a binding + x = e |> co +we want to do something very similar to worker/wrapper: + $wx = e + x = $wx |> co + +We call this making a cast worker/wrapper in tryCastWorkerWrapper. + +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + t = T m + go 0 = 0 + go n = case t of { T m -> go (n-m) } + -- This case should optimise + +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. + +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = -} + f = (\xy. ) |> co + Then we want to w/w to + {- $wf: Stable unfolding = |> sym co -} + $wf = \xy. + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + This point also applies to strong loopbreakers with INLINE pragmas, see + wrinkle (4). + +4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence + hasInlineUnfolding in tryCastWorkerWrapper, which responds False to + loop-breakers) because they'll definitely be inlined anyway, cast and + all. And if we do cast w/w for an INLINE function with arity zero, we get + something really silly: we inline that "worker" right back into the wrapper! + Worse than a no-op, because we have then lost the stable unfolding. + +All these wrinkles are exactly like worker/wrapper for strictness analysis: + f is the wrapper and must inline like crazy + $wf is the worker and must carry f's original pragma +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +See #17673, #18093, #18078, #19890. + +Note [Preserve strictness in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Cast worker/wrapper] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Preserve RuntimeRep info in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not do cast w/w when the presence of the coercion is needed in order +to determine the runtime representation. + +Example: + + Suppose we have a type family: + + type F :: RuntimeRep + type family F where + F = LiftedRep + + together with a type `ty :: TYPE F` and a top-level binding + + a :: ty |> TYPE F[0] + + The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. + However, were we to apply cast w/w, we would get: + + b :: ty + b = ... + + a :: ty |> TYPE F[0] + a = b `cast` GRefl (TYPE F[0]) + + Now we are in trouble because `ty :: TYPE F` does not have a known runtime + representation, because we need to be able to reduce the nullary type family + application `F` to find that out. + +Conclusion: only do cast w/w when doing so would not lose the RuntimeRep +information. That is, when handling `Cast rhs co`, don't attempt cast w/w +unless the kind of the type of rhs is concrete, in the sense of +Note [Concrete types] in GHC.Tc.Utils.Concrete. +-} + +tryCastWorkerWrapper :: SimplEnv -> BindContext + -> InId -> OccInfo + -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) + | BC_Let top_lvl is_rec <- bind_cxt -- Not join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 + , isConcrete (typeKind work_ty) -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] + , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings + -- See Note [OPAQUE pragma] + = do { uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + 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 + work_id (emptyFloats env) rhs + + ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = rhs_floats `addLetFloats` + unitLetFloat (NonRec work_id_w_unf work_rhs) + + triv_rhs = Cast (Var work_id_w_unf) co + + ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs Nothing ) } + + else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + uf_opts = seUnfoldingOpts env + work_ty = coercionLKind co + info = idInfo bndr + work_arity = arityInfo info `min` typeArity work_ty + + work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` work_arity + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding top_lvl work_id work_rhs + = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs + +tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings + = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs ]) + ; return (mkFloatBind env (NonRec bndr rhs)) } + +mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma +-- See Note [Cast worker/wrapper] +mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] + , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap + , inl_act = wrap_act -- See Note [Wrapper activation] + , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap + -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + -- But simpler, because we don't need to disable during InitialPhase + wrap_act | isNeverActive fn_act = activateDuringFinal + | otherwise = fn_act + + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool + -> Id -- Used only for its OccName; can be InId or OutId + -> SimplFloats -> OutExpr + -> SimplM (SimplFloats, OutExpr) +-- In (prepareBinding ... bndr floats rhs), the binding is really just +-- bndr = let floats in rhs +-- Maybe we can ANF-ise this binding and float out; e.g. +-- bndr = let a = f x in K a a (g x) +-- we could float out to give +-- a = f x +-- tmp = g x +-- bndr = K a a tmp +-- That's what prepareBinding does +-- Precondition: binder is not a JoinId +-- Postcondition: the returned SimplFloats contains only let-floats +prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs + = do { -- Never float join-floats out of a non-join let-binding (which this is) + -- So wrap the body in the join-floats right now + -- Hence: rhs_floats1 consists only of let-floats + let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs + + -- rhs_env: add to in-scope set the binders from rhs_floats + -- so that prepareRhs knows what is in scope in rhs + ; let rhs_env = env `setInScopeFromF` rhs_floats1 + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + + -- Now ANF-ise the remaining rhs + ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1 + + -- Finally, decide whether or not to float + ; let all_floats = rhs_floats1 `addLetFloats` anf_floats + ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 + then -- Float! + do { tick LetFloatFromLet + ; return (all_floats, rhs2) } + + else -- Abandon floating altogether; revert to original rhs + -- Since we have already built rhs1, we just need to add + -- rhs_floats1 to it + return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } + +{- Note [prepareRhs] +~~~~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: HasDebugCallStack + => SimplEnv -> TopLevelFlag + -> FastString -- Base for any new variables + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by ANF'ing args +-- for expandable RHSs: constructors and PAPs +-- e.g x = Just e +-- becomes a = e -- 'a' is fresh +-- x = Just a +-- See Note [prepareRhs] +prepareRhs env top_lvl occ rhs0 + = do { (_is_exp, floats, rhs1) <- go 0 rhs0 + ; return (floats, rhs1) } + where + go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) + go n_val_args (Cast rhs co) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Cast rhs' co) } + go n_val_args (App fun (Type ty)) + = do { (is_exp, floats, rhs') <- go n_val_args fun + ; return (is_exp, floats, App rhs' (Type ty)) } + go n_val_args (App fun arg) + = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun + ; if is_exp + then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg + ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } + else return (False, emptyLetFloats, App fun arg) + } + go n_val_args (Var fun) + = return (is_exp, emptyLetFloats, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in + -- 'GHC.Core.Opt.OccurAnal.occAnalApp' + + go n_val_args (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (is_exp, floats', Tick t rhs') } + + go _ other + = return (False, emptyLetFloats, other) + +makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e + ; return (floats, arg { as_arg = e' }) } +makeTrivialArg _ arg + = return (emptyLetFloats, arg) -- CastBy, TyArg + +makeTrivial :: HasDebugCallStack + => SimplEnv -> TopLevelFlag -> Demand + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] +makeTrivial env top_lvl dmd occ_fs expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | Cast expr' co <- expr + = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' + ; return (floats, Cast triv_expr co) } + + | otherwise -- 'expr' is not of form (Cast e co) + = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr + ; uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name ManyTy expr_ty id_info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 + -- Technically we should extend the in-scope set in 'env' with + -- the 'floats' from prepareRHS; but they are all fresh, so there is + -- no danger of introducing name shadowig in eta expansion + + ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2 + + ; let final_id = addLetBndrInfo var arity_type unf + bind = NonRec final_id expr2 + + ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } + where + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + uf_opts = seUnfoldingOpts env + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + - extend the InScopeSet of the SimplEnv + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: SimplEnv + -> BindContext + -> InId -- Old binder + -> OutId -- New binder; can be a JoinId + -> OutExpr -- New RHS + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let-can-float invariant +completeBind env bind_cxt old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = assert (isId new_bndr) $ + do { let old_info = idInfo old_bndr + old_unf = realUnfoldingInfo old_info + occ_info = occInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs + + -- Simplify the unfolding + ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf + + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs + -- See Note [Use occ-anald RHS in postInlineUnconditionally] + ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ + return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx unf_rhs (isJoinId_maybe new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding; do cast worker/wrapper + -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ + tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs } + +addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity_type new_unf + = new_bndr `setIdInfo` info5 + where + new_arity = arityTypeArity new_arity_type + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unf + = zapDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 = case arityTypeBotSigs_maybe new_arity_type of + Nothing -> info3 + Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $ + info3 `setDmdSigInfo` str_sig + `setCprSigInfo` cpr_sig + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of )... +or + let f = \y. error (y ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead immediately. So it's good to +propagate the info that x's (or f's) RHS is bottom to x's (or f's) +IdInfo as rapidly as possible. + +We use tryEtaExpandRhs on every binding, and it turns out that the +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +There is a second reason for settting the strictness signature. Consider + let -- f :: <[S]b> + f = \x. error "urk" + in ...(f a b c)... +Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` +to eta-expand to + let f = \x y z. error "urk" + in ...(f a b c)... + +But now f's strictness signature has too short an arity; see +GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. +Fortuitously, the same strictness-signature-fixup code +gives the function a new strictness signature with the right number of +arguments. Example in stranal/should_compile/EtaExpansion. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + +Note [Use occ-anald RHS in postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we postInlineUnconditionally 'f in + let f = \x -> x True in ...(f blah)... +then we'd like to inline the /occ-anald/ RHS for 'f'. If we +use the non-occ-anald version, we'll end up with a + ...(let x = blah in x True)... +and hence an extra Simplifier iteration. + +We already /have/ the occ-anald version in the Unfolding for +the Id. Well, maybe not /quite/ always. If the binder is Dead, +postInlineUnconditionally will return True, but we may not have an +unfolding because it's too big. Hence the belt-and-braces `orElse` +in the defn of unf_rhs. The Nothing case probably never happens. + + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF !env e !cont -- See Note [Bangs in the Simplifier] + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + ]) $ -} + simplExprF1 env e cont + +simplExprF1 :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> + -- Crucially, sc_hole_ty is a /lazy/ binding. It will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. + simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_hole_ty = substTy env (exprType fun) + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env (zapLambdaBndrs expr n_args) cont + -- zapLambdaBndrs: the issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + assert (isTyVar bndr) $ + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + -- Because of the let-can-float invariant, it's ok to + -- inline freely, or to drop the binding if it is dead. + = do { tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + -- Now check for a join point. It's better to do the preInlineUnconditionally + -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial + -- binding like { j = j2 |> co } would first be eta-expanded and then inlined + -- Better to test preInlineUnconditionally first. + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} + simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} + simplNonRecE env False bndr (rhs, env) body cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | Just arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { let opt_co = optCoercion opts (getSubst env) co + ; seqCo opt_co `seq` return opt_co } + where + opts = seOptCoercionOpts env + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. + +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint ext n ids <- tickish + = Breakpoint ext n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont (CastIt co c) = (CastIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = id + getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant; +-- only the in-scope set matters +rebuild env expr cont + = case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild env (mkTick t expr) cont + CastIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty ) cont + + StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont } + -> completeBindX (se `setInScopeFromE` env) b expr body cont + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag + , sc_cont = cont, sc_hole_ty = fun_ty } + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplArg env dup_flag fun_ty se arg + ; rebuild env (App expr arg') cont } + +completeBindX :: SimplEnv + -> InId -> OutExpr -- Bind this Id to this (simplified) expression + -- (the let-can-float invariant may not be satisfied) + -> InExpr -- In this lambda + -> SimplCont -- Consumed by this continuation + -> SimplM (SimplFloats, OutExpr) +completeBindX env bndr rhs body cont + | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (floats, expr') <- simplLam env1 body cont + -- Do not float floats past the Case binder below + ; let expr'' = wrapFloats floats expr' + ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] + ; return (emptyFloats env, case_expr) } + + | otherwise + = do { (floats1, env') <- simplNonRecX env bndr rhs + ; (floats2, expr') <- simplLam env' body cont + ; return (floats1 `addFloats` floats2, expr') } + + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + 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). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. +-} + + +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 cont0 + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont + addCoerceM MRefl cont = return cont + addCoerceM (MCo co) cont = addCoerce co cont + + addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont + addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] + | isReflexiveCo co' = return cont + | otherwise = addCoerce co' cont + where + co' = mkTransCo co1 co2 + + addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail + , sc_hole_ty = fun_ty }) + | Just (m_co1, m_co2) <- pushCoValArg co + , fixed_rep m_co1 + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- Avoid simplifying if possible; + -- See Note [Avoiding exponential behaviour] + + MCo co1 -> + do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + addCoerce co cont + | isReflexiveCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt co cont) + + fixed_rep :: MCoercionR -> Bool + fixed_rep MRefl = True + fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co + -- Without this check, we can get an argument which does not + -- have a fixed runtime representation. + -- See Note [Representation polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + +simplArg :: SimplEnv -> DupFlag + -> OutType -- Type of the function applied to this arg + -> StaticEnv -> CoreExpr -- Expression with its static envt + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplArg env dup_flag fun_ty arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { let arg_env' = arg_env `setInScopeFromE` env + ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty)) + ; return (Simplified, zapSubstEnv arg_env', arg') } + -- Return a StaticEnv that includes the in-scope set from 'env', + -- because arg' may well mention those variables (#20639) + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplLam :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont +simplLam env expr cont = simplExprF env expr cont + +simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- Type beta-reduction +simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) body cont } + +-- Value beta-reduction +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup }) + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; completeBindX env bndr arg body cont } + + | otherwise -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; simplNonRecE env True bndr (arg, arg_se) body cont } + +-- Discard a non-counting tick on a lambda. This may change the +-- cost attribution slightly (moving the allocation of the +-- lambda elsewhere), but we don't care: optimisation changes +-- cost attribution all the time. +simpl_lam env bndr body (TickIt tickish cont) + | not (tickishCounts tickish) + = simpl_lam env bndr body cont + +-- Not enough args, so there are real lambdas left to put in the result +simpl_lam env bndr body cont + = do { let (inner_bndrs, inner_body) = collectBinders body + ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) + ; body' <- simplExpr env' inner_body + ; new_lam <- rebuildLam env' bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Historically this had a special case for when a lambda-binder +-- could have a stable unfolding; +-- see Historical Note [Case binders and join points] +-- But now it is much simpler! We now only remove unfoldings. +-- See Note [Never put `OtherCon` unfoldings on lambda binders] +simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: SimplEnv + -> Bool -- True <=> from a lambda + -- False <=> from a let + -> InId -- The binder, always an Id + -- Never a join point + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive non-join-point lets in expressions +-- * beta reduction +-- +-- simplNonRec env b (rhs, rhs_se) body k +-- = let env in +-- cont< let b = rhs_se(rhs) in body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process. +-- +-- from_lam=False => the RHS satisfies the let-can-float invariant +-- Otherwise it may or may not satisfy it. + +simplNonRecE env from_lam bndr (rhs, rhs_se) body cont + = assert (isId bndr && not (isJoinId bndr) ) $ + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs + -- See Note [Dark corner with representation polymorphism] + -- If from_lam=False then needs_case_binding is False, + -- because the binding started as a let, which must + -- satisfy let-can-float + + ; if | from_lam && not needs_case_binding + -- If not from_lam we are coming from a (NonRec bndr rhs) binding + -- and preInlineUnconditionally has been done already; + -- no need to repeat it. But for lambdas we must be careful about + -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk") + -- We must not drop the (error "urk"). + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se + -> do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam env' body cont } + + -- Deal with strict bindings + | isStrictId bndr1 && seCaseCase env + || from_lam && needs_case_binding + -- The important bit here is needs_case_binds; but no need to + -- test it if from_lam is False because then needs_case_binding is False too + -- NB: either way, the RHS may or may not satisfy let-can-float + -- but that's ok for StrictBind. + -> simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + | otherwise + -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; (floats2, expr') <- simplLam env3 body cont + ; return (floats1 `addFloats` floats2, expr') } } + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +-- Precondition: not a join-point binding +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; massert (all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Dark corner with representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail +if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). +So we are careful to call `isStrictId` on the OutId, not the InId, in case we have + ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell +if x is lifted or unlifted from that. + +We only get such redexes from the compulsory inlining of a wired-in, +representation-polymorphic function like `rightSection` (see +GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined +such compulsory inlinings already, but belt and braces does no harm. + +Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the +Simplifier without first calling SimpleOpt, so anything involving +GHCi or TH and operator sections will fall over if we don't take +care here. + +Note [Avoiding exponential behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and then re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression. That is why simplNonRecX does not try +preInlineUnconditionally (unlike simplNonRecE). + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + * We inline f = \x. x True + * So if we did preInlineUnconditionally we'd re-simplify (BIG True) + +However, if BIG has /not/ already been simplified, we'd /like/ to +simplify BIG True; maybe good things happen. That is why + +* simplLam has + - a case for (isSimplified dup), which goes via simplNonRecX, and + - a case for the un-simplified case, which goes via simplNonRecE + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - In rebuildCall we avoid simplifying arguments before we have to + (see Note [Trying rewrite rules]) + + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + = assert (isJoinId bndr ) $ + wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let mult = contHoleScaling cont + res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) + ; (floats1, env3) <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + mult = contHoleScaling cont + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env bndrs mult res_ty + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (seCaseCase env) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -- Used only in error message + -> Maybe JoinArity + -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ Nothing cont + = cont -- Not a jump +trimJoinCont var (Just arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) into +both the RHS and the body of the join point j. But since we aren't doing +case-of-case we may then end up with this totally bogus result + + join x = case of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +This would be OK in the language of the paper, but not in GHC: j is no longer +a join point. We can only do the "push continuation into the RHS of the +join point j" if we also push the continuation right down to the /jumps/ to +j, so that it can evaporate there. If we are doing case-of-case, we'll get to + + join x = case of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ + +Note [zapSubstEnv] +~~~~~~~~~~~~~~~~~~ +When simplifying something that has already been simplified, be sure to +zap the SubstEnv. This is VITAL. Consider + let x = e in + let y = \z -> ...x... in + \ x -> ...y... + +We'll clone the inner \x, adding x->x' in the id_subst Then when we +inline y, we must *not* replace x by x' in the inlined copy!! + +Note [Fast path for data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For applications of a data constructor worker, the full glory of +rebuildCall is a waste of effort; +* They never inline, obviously +* They have no rewrite rules +* They are not strict (see Note [Data-con worker strictness] + in GHC.Core.DataCon) +So it's fine to zoom straight to `rebuild` which just rebuilds the +call in a very straightforward way. + +Some programs have a /lot/ of data constructors in the source program +(compiler/perf/T9961 is an example), so this fast path can be very +valuable. +-} + +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + -- Why $! ? See Note [Bangs in the Simplifier] + | isTyVar var = return $! Type $! (substTyVar env var) + | isCoVar var = return $! Coercion $! (substCoVar env var) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids + in simplExpr env' e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplIdF env var cont + | isDataConWorkId var -- See Note [Fast path for data constructors] + = rebuild env (Var var) cont + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> simplExprF env' e cont + -- Don't trimJoinCont; haven't already simplified e, + -- so the cont is not embodied in e + where + env' = setSubstEnv env tvs cvs ids + + DoneId var1 -> + do { rule_base <- getSimplRules + ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont + info = mkArgInfo env rule_base var1 cont' + ; rebuildCall env info cont' } + + DoneEx e mb_join -> simplExprF env' e cont' + where + cont' = trimJoinCont var mb_join cont + env' = zapSubstEnv env -- See Note [zapSubstEnv] + +--------------------------------------------------------- +-- Dealing with a call site + +rebuildCall :: SimplEnv -> ArgInfo -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Try inlining, if ai_rewrite = TryInlining -------- +-- In the TryInlining case we try inlining immediately, before simplifying +-- any (more) arguments. Why? See Note [Rewrite rules and inlining]. +-- +-- If there are rewrite rules we'll skip this case until we have +-- simplified enough args to satisfy nr_wanted==0 in the TryRules case below +-- Then we'll try the rules, and if that fails, we'll do TryInlining +rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args + , ai_rewrite = TryInlining }) cont + = do { logger <- getLogger + ; let full_cont = pushSimplifiedRevArgs env rev_args cont + ; mb_inline <- tryInlining env logger fun full_cont + ; case mb_inline of + Just expr -> do { checkedTick (UnfoldingDone fun) + ; let env1 = zapSubstEnv env + ; simplExprF env1 expr full_cont } + Nothing -> rebuildCall env (info { ai_rewrite = TryNothing }) cont + } + +---------- Try rewrite RULES, if ai_rewrite = TryRules -------------- +-- See Note [Rewrite rules and inlining] +-- See also Note [Trying rewrite rules] +rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args + , ai_rewrite = TryRules nr_wanted rules }) cont + | nr_wanted == 0 || no_more_args + = -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULES apply to simplified arguments] + -- See also Note [Rules for recursive functions] + do { mb_match <- tryRules env rules fun (reverse rev_args) cont + ; case mb_match of + Just (env', rhs, cont') -> simplExprF env' rhs cont' + Nothing -> rebuildCall env (info { ai_rewrite = TryInlining }) cont } + where + -- If we have run out of arguments, just try the rules; there might + -- be some with lower arity. Casts get in the way -- they aren't + -- allowed on rule LHSs + no_more_args = case cont of + ApplyToTy {} -> False + ApplyToVal {} -> False + _ -> True + +---------- Simplify type applications and casts -------------- +rebuildCall env info (CastIt co cont) + = rebuildCall env (addCastTo info co) cont + +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont + +---------- The runRW# rule. Do this after absorbing all arguments ------ +-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. +-- +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) +rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_hole_ty = fun_ty }) + | fun_id `hasKey` runRWKey + , [ TyArg {}, TyArg {} ] <- rev_args + -- Do this even if (contIsStop cont) + -- See Note [No eta-expansion in runRW#] + = do { let arg_env = arg_se `setInScopeFromE` env + ty' = contResultType cont + + -- If the argument is a literal lambda already, take a short cut + -- This isn't just efficiency; if we don't do this we get a beta-redex + -- every time, so the simplifier keeps doing more iterations. + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body cont + ; 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") ManyTy realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = arg_env `addNewInScopeIds` [s'] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' + , sc_env = env', sc_cont = cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep ty' + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +---------- Simplify value arguments -------------------- +rebuildCall env fun_info + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_hole_ty = fun_ty + , sc_cont = cont }) + -- Argument is already simplified + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont + + -- Strict arguments + | isStrictArgInfo fun_info + , seCaseCase env + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = Simplified + , sc_cont = cont }) + -- Note [Shadowing] + + -- Lazy arguments + | otherwise + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg + (mkLazyArgStop arg_ty fun_info) + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + where + arg_ty = funArgTy fun_ty + + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont + = rebuild env (argInfoExpr fun rev_args) cont + +----------------------------------- +tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) +tryInlining env logger var cont + | Just expr <- callSiteInline logger uf_opts case_depth var active_unf + lone_variable arg_infos interesting_cont + = do { dump_inline expr cont + ; return (Just expr) } + + | otherwise + = return Nothing + + where + uf_opts = seUnfoldingOpts env + case_depth = seCaseDepth env + (lone_variable, arg_infos, call_cont) = contArgs cont + interesting_cont = interestingCallContext env call_cont + active_unf = activeUnfolding (seMode env) var + + log_inlining doc + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) + Opt_D_dump_inlinings + "" FormatText doc + + dump_inline unfolding cont + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + + +{- Note [Trying rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet +simplified. We want to simplify enough arguments to allow the rules +to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone +is sufficient. Example: class ops + (+) dNumInt e2 e3 +If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the +latter's strictness when simplifying e2, e3. Moreover, suppose we have + RULE f Int = \x. x True + +Then given (f Int e1) we rewrite to + (\x. x True) e1 +without simplifying e1. Now we can inline x into its unique call site, +and absorb the True into it all in the same pass. If we simplified +e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. + +So we try to apply rules if either + (a) no_more_args: we've run out of argument that the rules can "see" + (b) nr_wanted: none of the rules wants any more arguments + + +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweep. + +Note [Rewrite rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we try to arrange that inlining is disabled (via a pragma) if +a rewrite rule should apply, so that the rule has a decent chance to fire +before we inline the function. + +But it turns out that (especially when type-class specialisation or +SpecConstr is involved) it is very helpful for the the rewrite rule to +"win" over inlining when both are active at once: see #21851, #22097. + +The simplifier arranges to do this, as follows. In effect, the ai_rewrite +field of the ArgInfo record is the state of a little state-machine: + +* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite + rules avaialable for that function. + +* rebuildCall simplifies arguments until enough are simplified to match the + rule with greatest arity. See Note [RULES apply to simplified arguments] + and the first field of `TryRules`. + + But no more! As soon as we have simplified enough arguments to satisfy the + maximum-arity rules, we try the rules; see Note [Trying rewrite rules]. + +* Once we have tried rules (or immediately if there are no rules) set + ai_rewrite to TryInlining, and the Simplifier will try to inline the + function. We want to try this immediately (before simplifying any (more) + arguments). Why? Consider + f BIG where f = \x{OneOcc}. ...x... + If we inline `f` before simplifying `BIG` well use preInlineUnconditionally, + and we'll simplify BIG once, at x's occurrence, rather than twice. + +* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no + unfolding, we can skip both TryRules and TryInlining, which saves work. + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + +Note [No eta-expansion in runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see `runRW# (\s. blah)` we must not attempt to eta-expand that +lambda. Why not? Because +* `blah` can mention join points bound outside the runRW# +* eta-expansion uses arityType, and +* `arityType` cannot cope with free join Ids: + +So the simplifier spots the literal lambda, and simplifies inside it. +It's a very special lambda, because it is the one the OccAnal spots and +allows join points bound /outside/ to be called /inside/. + +See Note [No free join points in arityType] in GHC.Core.Opt.Arity + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> Id + -> [ArgSpec] -- In /normal, forward/ order + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) + +tryRules env rules fn args call_cont + | null rules + = return Nothing + +{- Disabled until we fix #8326 + | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] + , [_type_arg, val_arg] <- args + , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont + , isDeadBinder bndr + = do { let enum_to_tag :: CoreAlt -> CoreAlt + -- Takes K -> e into tagK# -> e + -- where tagK# is the tag of constructor K + enum_to_tag (DataAlt con, [], rhs) + = assert (isEnumerationTyCon (dataConTyCon con) ) + (LitAlt tag, [], rhs) + where + tag = mkLitInt (sePlatform env) (toInteger (dataConTag con - fIRST_TAG)) + enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) + + new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts + new_bndr = setIdType bndr intPrimTy + -- The binder is dead, but should have the right type + ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } +-} + + | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) + (activeRule (seMode env)) fn + (argInfoAppArgs args) rules + -- Fire a rule for the function + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName rule)) + ; let cont' = pushSimplifiedArgs zapped_env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how + -- many args the rule consumed + + occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump logger rule rule_rhs + ; return (Just (zapped_env, occ_anald_rhs, cont')) } + -- The occ_anald_rhs and cont' are all Out things + -- hence zapping the environment + + | otherwise -- No rule fires + = do { logger <- getLogger + ; nodump logger -- This ensures that an empty file is written + ; return Nothing } + + where + ropts = seRuleOpts env + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump logger rule rule_rhs + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> hang (pprCoreExpr rule_rhs) 2 + (sep $ map ppr $ drop (ruleArity rule) args) + , text "Cont: " <+> ppr call_cont ] + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump logger + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_rewrites + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_firings + + | otherwise + = return () + + log_rule flag hdr details + = do + { logger <- getLogger + ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] + } + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } + where + no_cast_scrut = drop_casts scrut + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b + res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b + res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b + res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty + res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + out_args = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont + , sc_hole_ty = res4_ty } + + -- Lazily evaluated, so we don't do most of this + + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Possible improvement: occ-anal the rules when putting them in the +database; and in the simplifier just occ-anal the OutExpr arguments. +But that's more complicated and the rule RHS is usually tiny; so I'm +just doing the simple thing. + +Historical note: previously we did occ-anal the rules in Rule.hs, +but failed to occ-anal the OutExpr arguments, which led to the +nasty performance problem described above. + + +Note [Optimising tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an enumeration data type: + + data Foo = A | B | C + +Then we want to transform + + case tagToEnum# x of ==> case x of + A -> e1 DEFAULT -> e1 + B -> e2 1# -> e2 + C -> e3 2# -> e3 + +thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT +alternative we retain it (remember it comes first). If not the case must +be exhaustive, and we reflect that in the transformed version by adding +a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. +See #8317. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let-can-float invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case of r { _ -> ..r.. } + +where 'r' is used strictly in (..r..), we can safely transform to + let r = in ...r... + +This is a Good Thing, because 'r' might be dead (if the body just +calls error), or might be used just once (in which case it can be +inlined); or we might be able to float the let-binding up or down. +E.g. #15631 has an example. + +Note that this can change the error behaviour. For example, we might +transform + case x of { _ -> error "bad" } + --> error "bad" +which is might be puzzling if 'x' currently lambda-bound, but later gets +let-bound to (error "good"). + +Nevertheless, the paper "A semantics for imprecise exceptions" allows +this transformation. If you want to fix the evaluation order, use +'pseq'. See #8900 for an example where the loss of this +transformation bit us in practice. + +See also Note [Empty case alternatives] in GHC.Core. + +Historical notes + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. + +Note [Do not duplicate constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#20125) + let x = (a,b) + in ...(case x of x' -> blah)...x...x... + +We want that `case` to vanish (since `x` is bound to a data con) leaving + let x = (a,b) + in ...(let x'=x in blah)...x..x... + +In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, +since is bound to (a,b). But in eliminating the case, if the scrutinee +is trivial, we want to bind the case-binder to the scrutinee, /not/ to +the constructor application. Hence the case_bndr_rhs in rebuildCase. + +This applies equally to a non-DEFAULT case alternative, say + let x = (a,b) in ...(case x of x' { (p,q) -> blah })... +This variant is handled by bind_case_bndr in knownCon. + +We want to bind x' to x, and not to a duplicated (a,b)). +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats + -- case_bndr_unf: see Note [Do not duplicate constructor applications] + case_bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId con) `mkTyApps` ty_args + `mkApps` other_args + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + other_args case_bndr bs rhs cont + } + where + simple_rhs env wfloats case_bndr_rhs bs rhs = + assert (null bs) $ + do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs + -- scrut is a constructor application, + -- hence satisfies let-can-float invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleVarBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A %1 -> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplNonRecX env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + -- Using `exprType` is typically cheap because `scrut` is typically a variable. + -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts + -- the brain more. Consider that if this test ever turns out to be a perf + -- problem (which seems unlikely). + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + || isStrUsedDmd (idDemandInfo case_bndr) + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (seCaseCase env) + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild env case_expr cont } + + | otherwise + = do { (floats, env', cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts env' scrut + (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + cont' + ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +"GHC.Core.Opt.OccurAnal" Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [Case alternative occ info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are simply reconstructing a case (the common case), we always +zap the occurrence info on the binders in the alternatives. Even +if the case binder is dead, the scrutinee is usually a variable, and *that* +can bring the case-alternative binders back to life. +See Note [Add unfolding for scrutinee] + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + fam_envs = seFamEnvs env0 + + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts + -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils + + ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts +-- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- 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") 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) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) + = assert (null bndrs) $ + do { let env' = addBinderUnfolding env case_bndr' + (mkOtherCon imposs_deflt_cons) + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt DEFAULT [] rhs') } + +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) + = assert (null bndrs) $ + do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt (LitAlt lit) [] rhs') } + +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + let vs_with_evals = addEvals scrut' con vs + ; (env', vs') <- simplBinders env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + + ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app + ; rhs' <- simplExprC env'' rhs cont' + ; return (Alt (DataAlt con) vs' rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Data-con worker strictness] in GHC.Core.DataCon + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +addEvals scrut con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleDataCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , Just SeqOp <- isPrimOpId_maybe f + , let x' = zapIdOccInfoAndSetEvald MarkedStrict x + = [s, x'] + + -- Deal with banged datacon fields +addEvals _scrut con vs = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs + go _ _ = pprPanic "Simplify.addEvals" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp :: StrictnessMark -> SDoc + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id +zapIdOccInfoAndSetEvald str v = + setCaseBndrEvald str $ -- Add eval'dness info + zapIdOccInfo v -- And kill occ info; + -- see Note [Case alternative occ info] + +addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv +addAltUnfoldings env mb_scrut case_bndr con_app + = do { let con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 | Just scrut <- mb_scrut + , Just (v,mco) <- scrutBinderSwap_maybe scrut + = addBinderUnfolding env1 v $ + if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf + then con_app_unf -- twice in the common case + else mk_simple_unf (mkCastMCo con_app mco) + + | otherwise = env1 + + ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr mb_scrut, ppr con_app]) + ; return env2 } + where + -- Force the opts, so that the whole SimplEnv isn't retained + !opts = seUnfoldingOpts env + mk_simple_unf = mkSimpleUnfolding opts + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + "unfolding type mismatch" + (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let-can-float invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... + ; K -> blah } + +The let-can-float invariant requires that y is evaluated in the call to +reallyUnsafePtrEquality#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccurAnal has got rid of all such occurrences +See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + +Since this transformation is tantamount to a binder swap, we use +GHC.Core.Opt.OccurAnal.scrutBinderSwap_maybe to do the check. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = assert (isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = assert (isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = assert (isId b) $ + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut Nothing)) + -- See Note [Do not duplicate constructor applications] + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = warnPprTrace True "missingAlt" (ppr case_bndr) $ + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt") + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM ( SimplFloats -- Join points (if any) + , SimplEnv -- Use this for the alts + , SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont + ; let env' = bumpCaseDepth $ + env `setInScopeFromF` floats + ; return (floats, env', cont) } + | otherwise = return (emptyFloats env, env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + -- otherwise case: first alt is non-bot, so all the rest must be bot + where + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + +------------------------- +mkDupableCont :: SimplEnv + -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation +mkDupableCont env cont + = mkDupableContWithDmds env (repeat topDmd) cont + +mkDupableContWithDmds + :: SimplEnv -> [Demand] -- Demands on arguments; always infinite + -> SimplCont -> SimplM ( SimplFloats, SimplCont) + +mkDupableContWithDmds env _ cont + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableContWithDmds env dmds (CastIt ty cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, CastIt ty cont') } + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableContWithDmds env dmds (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, TickIt t cont') } + +mkDupableContWithDmds env _ + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = se, sc_cont = cont}) +-- See Note [Duplicating StrictBind] +-- K[ let x = <> in b ] --> join j x = K[ b ] +-- j <> + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplLam sb_env1 body cont + -- No need to use mkDupableCont before simplLam; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; mkDupableStrictBind env bndr' join_body res_ty } + +mkDupableContWithDmds env _ + (StrictArg { sc_fun = fun, sc_cont = cont + , sc_fun_ty = fun_ty }) + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + | isNothing (isDataConId_maybe (ai_fun fun)) + , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] + = -- Use Plan A of Note [Duplicating StrictArg] + do { let (_ : dmds) = ai_dmds fun + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) + (ai_args fun) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = fun { ai_args = args' } + , sc_cont = cont' + , sc_fun_ty = fun_ty + , sc_dup = OkToDup} ) } + + | otherwise + = -- Use Plan B of Note [Duplicating StrictArg] + -- K[ f a b <> ] --> join j x = K[ f a b x ] + -- j <> + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + where + thumbsUpPlanA (StrictArg {}) = False + thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (Select {}) = True + thumbsUpPlanA (StrictBind {}) = True + thumbsUpPlanA (Stop {}) = True + +mkDupableContWithDmds env dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplArg env' dup hole_ty se arg + ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ + (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; let platform = sePlatform env + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt platform case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType + -> SimplM (SimplFloats, SimplCont) +mkDupableStrictBind env arg_bndr join_rhs res_ty + | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] + = return (emptyFloats env + , StrictBind { sc_bndr = arg_bndr + , sc_body = join_rhs + , sc_env = zapSubstEnv env + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) + | otherwise + = do { join_bndr <- newJoinId [arg_bndr] res_ty + ; let arg_info = ArgInfo { ai_fun = join_bndr + , ai_rewrite = TryNothing, ai_args = [] + , ai_encl = False, ai_dmds = repeat topDmd + , ai_discs = repeat 0 } + ; return ( addJoinFloats (emptyFloats env) $ + unitJoinFloat $ + NonRec join_bndr $ + Lam (setOneShotLambda arg_bndr) join_rhs + , StrictArg { sc_dup = OkToDup + , sc_fun = arg_info + , sc_fun_ty = idType join_bndr + , sc_cont = mkBoringStop res_ty + } ) } + +mkDupableAlt :: Platform -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) + | exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points] + = return (jfloats, Alt con alt_bndrs alt_rhs_in) + + | otherwise + = do { let rhs_ty' = exprType alt_rhs_in + + bangs + | DataAlt c <- con + = dataConRepStrictness c + | otherwise = [] + + abstracted_binders = abstract_binders alt_bndrs bangs + + abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] + abstract_binders [] [] + -- Abstract over the case binder too if it's used. + | isDeadBinder case_bndr = [] + | otherwise = [(case_bndr,MarkedStrict)] + abstract_binders (alt_bndr:alt_bndrs) marks + -- Abstract over all type variables just in case + | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks + abstract_binders (alt_bndr:alt_bndrs) (mark:marks) + -- The deadness info on the new Ids is preserved by simplBinders + -- We don't abstract over dead ids here. + | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks + | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks + abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) + + filtered_binders = map fst abstracted_binders + -- We want to make any binder with an evaldUnfolding strict in the rhs. + -- See Note [Call-by-value for worker args] (which also applies to join points) + (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in + + final_args = varsToCoreExprs filtered_binders + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + final_bndrs = map one_shot filtered_binders + one_shot v | isId v = setOneShotLambda v + | otherwise = v + + -- No lambda binder has an unfolding, but (currently) case binders can, + -- so we must zap them here. + join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs + + ; join_bndr <- newJoinId filtered_binders rhs_ty' + + ; let join_call = mkApps (Var join_bndr) final_args + alt' = Alt con alt_bndrs join_call + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IN #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K x y). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. In contrast, if we /don't/ inline $j we +don't need a join point for `blah` and we'll get + join $j x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j x1 + p2 -> $j x2 + p3 -> $j x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +To achieve this: + +1. Do not postInlineUnconditionally a join point, until the Final + phase. (The Final phase is still quite early, so we might consider + delaying still more.) + +2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for + all alternatives, except for exprIsTrival RHSs. Previously we used + exprIsDupable. This generates a lot more join points, but makes + them much more case-of-case friendly. + + It is definitely worth checking for exprIsTrivial, otherwise we get + an extra Simplifier iteration, because it is inlined in the next + round. + +3. By the same token we want to use Plan B in + Note [Duplicating StrictArg] when the RHS of the new join point + is a data constructor application. That same Note explains why we + want Plan A when the RHS of the new join point would be a + non-data-constructor application + +4. You might worry that $j will be inlined by the call-site inliner, + but it won't because the call-site context for a join is usually + extremely boring (the arguments come from the pattern match). + And if not, then perhaps inlining it would be a good idea. + + You might also wonder if we get UnfWhen, because the RHS of the + join point is no bigger than the call. But in the cases we care + about it will be a little bigger, because of that free `f` in + $j x = K f x + So for now we don't do anything special in callSiteInline + +There is a bit of tension between (2) and (3). Do we want to retain +the join point only when the RHS is +* a constructor application? or +* just non-trivial? +Currently, a bit ad-hoc, but we definitely want to retain the join +point for data constructors in mkDupalbleALt (point 2); that is the +whole point of #19996 described above. + +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with making a StrictArg continuation duplicable has turned out +to be one of the trickiest corners of the simplifier, giving rise +to several cases in which the simplier expanded the program's size +*exponentially*. They include + #13253 exponential inlining + #10421 ditto + #18140 strict constructors + #18282 another nested-function call case + +Suppose we have a call + f e1 (case x of { True -> r1; False -> r2 }) e3 +and f is strict in its second argument. Then we end up in +mkDupableCont with a StrictArg continuation for (f e1 <> e3). +There are two ways to make it duplicable. + +* Plan A: move the entire call inwards, being careful not + to duplicate e1 or e3, thus: + let a1 = e1 + a3 = e3 + in case x of { True -> f a1 r1 a3 + ; False -> f a1 r2 a3 } + +* Plan B: make a join point: + join $j x = f e1 x e3 + in case x of { True -> jump $j r1 + ; False -> jump $j r2 } + + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') + +If we pushed the entire call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this particular program. + +Here is another example. + && E (case x of { T -> F; F -> T }) + +Pushing the call inward (being careful not to duplicate E) + let a = E + in case x of { T -> && a F; F -> && a T } + +and now the (&& a F) etc can optimise. Moreover there might +be a RULE for the function that can fire when it "sees" the +particular case alternative. + +But Plan A can have terrible, terrible behaviour. Here is a classic +case: + f (f (f (f (f True)))) + +Suppose f is strict, and has a body that is small enough to inline. +The innermost call inlines (seeing the True) to give + f (f (f (f (case v of { True -> e1; False -> e2 })))) + +Now, suppose we naively push the entire continuation into both +case branches (it doesn't look large, just f.f.f.f). We get + case v of + True -> f (f (f (f e1))) + False -> f (f (f (f e2))) + +And now the process repeats, so we end up with an exponentially large +number of copies of f. No good! + +CONCLUSION: we want Plan A in general, but do Plan B is there a +danger of this nested call behaviour. The function that decides +this is called thumbsUpPlanA. + +Note [Keeping demand info in StrictArg Plan A] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following on from Note [Duplicating StrictArg], another common code +pattern that can go bad is this: + f (case x1 of { T -> F; F -> T }) + (case x2 of { T -> F; F -> T }) + ...etc... +when f is strict in all its arguments. (It might, for example, be a +strict data constructor whose wrapper has not yet been inlined.) + +We use Plan A (because there is no nesting) giving + let a2 = case x2 of ... + a3 = case x3 of ... + in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } + +Now we must be careful! a2 and a3 are small, and the OneOcc code in +postInlineUnconditionally may inline them both at both sites; see Note +Note [Inline small things to avoid creating a thunk] in +Simplify.Utils. But if we do inline them, the entire process will +repeat -- back to exponential behaviour. + +So we are careful to keep the demand-info on a2 and a3. Then they'll +be /strict/ let-bindings, which will be dealt with by StrictBind. +That's why contIsDupableWithDmds is careful to propagage demand +info to the auxiliary bindings it creates. See the Demand argument +to makeTrivial. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = <> in b ==> join j x = b + in j <> + +Just like StrictArg in fact -- and indeed they share code. + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv + -> BindContext + -> InId + -> OutExpr -> OutType -> ArityType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf + | isStableUnfolding unf + = simplStableUnfolding env bind_cxt id rhs_ty arity unf + | isExitJoinId id + = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + | otherwise + = -- Otherwise, we end up retaining all the SimpleEnv + let !opts = seUnfoldingOpts env + in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs + +------------------- +mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource + -> InId -> OutExpr -> SimplM Unfolding +mkLetUnfolding !uf_opts top_lvl src id new_rhs + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + -- Might as well force this, profiles indicate up to 0.5MB of thunks + -- just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id + +------------------- +simplStableUnfolding :: SimplEnv -> BindContext + -> InId + -> OutType + -> ArityType -- Used to eta expand, but only for non-join-points + -> Unfolding + ->SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env bind_cxt id rhs_ty id_arity unf + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case bind_cxt of + BC_Join _ cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont + BC_Let _ is_rec -> -- Binder is not a join point + do { let cont = mkRhsStop rhs_ty is_rec topDmd + -- mkRhsStop: switch off eta-expansion at the top level + ; expr' <- simplExprC unf_env expr cont + ; return (eta_expand expr') } + ; case guide of + UnfWhen { ug_boring_ok = boring_ok } + -- Happens for INLINE things + -- Really important to force new_boring_ok since otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = guide { ug_boring_ok = new_boring_ok } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding uf_opts top_lvl src id expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + uf_opts = seUnfoldingOpts env + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + top_lvl = bindContextLevel bind_cxt + !is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + + -- See Note [Eta-expand stable unfoldings] + -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + -- Not used for join points + eta_expand expr | seEtaExpand env + , exprArity expr < arityTypeArity id_arity + , wantEtaExpansion expr + = etaExpandAT (getInScope env) id_arity expr + | otherwise + = expr + +{- Note [Eta-expand stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For INLINE/INLINABLE things (which get stable unfoldings) there's a danger +of getting + f :: Int -> Int -> Int -> Blah + [ Arity = 3 -- Good arity + , Unf=Stable (\xy. blah) -- Less good arity, only 2 + f = \pqr. e + +This can happen because f's RHS is optimised more vigorously than +its stable unfolding. Now suppose we have a call + g = f x +Because f has arity=3, g will have arity=2. But if we inline f (using +its stable unfolding) g's arity will reduce to 1, because +hasn't been optimised yet. This happened in the 'parsec' library, +for Text.Pasec.Char.string. + +Generally, if we know that 'f' has arity N, it seems sensible to +eta-expand the stable unfolding to arity N too. Simple and consistent. + +Wrinkles + +* See Historical-note [Eta-expansion in stable unfoldings] in + GHC.Core.Opt.Simplify.Utils + +* Don't eta-expand a trivial expr, else each pass will eta-reduce it, + and then eta-expand again. See Note [Which RHSs do we eta-expand?] + in GHC.Core.Opt.Simplify.Utils. + +* Don't eta-expand join points; see Note [Do not eta-expand join points] + in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point + case (bind_cxt = BC_Join {}) doesn't use eta_expand. + +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> BindContext + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id bind_cxt + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] +-- Simplify local rules for imported Ids +simplImpRules env rules + = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> BindContext -> SimplM [CoreRule] +simplRules env mb_new_id rules bind_cxt + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_act = act }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] + BC_Let {} -> mkBoringStop rhs_ty + BC_Join _ cont -> assertPpr join_ok bad_join_msg cont + lhs_env = updMode updModeForRules env' + rhs_env = updMode (updModeForStableUnfoldings act) env' + -- See Note [Simplifying the RHS of a RULE] + -- Force this to avoid retaining reference to old Id + !fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | Just join_arity <- isJoinId_maybe id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap isJoinId_maybe mb_new_id) ] + + ; args' <- mapM (simplExpr lhs_env) args + ; rhs' <- simplExprC rhs_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = rhs' }) } + +{- Note [Simplifying the RHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can simplify the RHS of a RULE much as we do the RHS of a stable +unfolding. We used to use the much more conservative updModeForRules +for the RHS as well as the LHS, but that seems more conservative +than necesary. Allowing some inlining might, for example, eliminate +a binding. +-} diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE PatternSynonyms #-} +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +module GHC.Core.Opt.Simplify.Monad ( + -- The monad + TopEnvConfig(..), SimplM, + initSmpl, traceSmpl, + getSimplRules, + + -- Unique supply + MonadUnique(..), newId, newJoinId, + + -- Counting + SimplCount, tick, freeTick, checkedTick, + getSimplCount, zeroSimplCount, pprSimplCount, + plusSimplCount, isZeroSimplCount + ) where + +import GHC.Prelude + +import GHC.Types.Var ( Var, isId, mkLocalVar ) +import GHC.Types.Name ( mkSystemVarName ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) +import GHC.Core.Type ( Type, Mult ) +import GHC.Core.Opt.Stats +import GHC.Core.Rules +import GHC.Core.Utils ( mkLamTypes ) +import GHC.Types.Unique.Supply +import GHC.Driver.Flags +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad +import GHC.Utils.Logger as Logger +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 ManyTy ) +import GHC.Exts( oneShot ) + +{- +************************************************************************ +* * +\subsection{Monad plumbing} +* * +************************************************************************ +-} + +newtype SimplM result + = SM' { unSM :: SimplTopEnv + -> SimplCount + -> IO (result, SimplCount)} + -- We only need IO here for dump output, but since we already have it + -- we might as well use it for uniques. + +pattern SM :: (SimplTopEnv -> SimplCount + -> IO (result, SimplCount)) + -> SimplM result +-- This pattern synonym makes the simplifier monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- (worth a 1-2% reduction in bytes-allocated). See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern SM m <- SM' m + where + SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct) + +-- See Note [The environments of the Simplify pass] +data TopEnvConfig = TopEnvConfig + { te_history_size :: !Int + , te_tick_factor :: !Int + } + +data SimplTopEnv + = STE { -- See Note [The environments of the Simplify pass] + st_config :: !TopEnvConfig + , st_logger :: !Logger + , st_max_ticks :: !IntWithInf -- ^ Max #ticks in this simplifier run + , st_read_ruleenv :: !(IO RuleEnv) + -- ^ The action to retrieve an up-to-date EPS RuleEnv + -- See Note [Overall plumbing for rules] + } + +initSmpl :: Logger + -> IO RuleEnv + -> TopEnvConfig + -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow + -> SimplM a + -> IO (a, SimplCount) + +initSmpl logger read_ruleenv cfg size m + = do -- No init count; set to 0 + let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + unSM m env simplCount + where + env = STE { st_config = cfg + , st_logger = logger + , st_max_ticks = computeMaxTicks cfg size + , st_read_ruleenv = read_ruleenv + } + +computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf +-- Compute the max simplifier ticks as +-- (base-size + pgm-size) * magic-multiplier * tick-factor/100 +-- where +-- magic-multiplier is a constant that gives reasonable results +-- base-size is a constant to deal with size-zero programs +computeMaxTicks cfg size + = treatZeroAsInf $ + fromInteger ((toInteger (size + base_size) + * toInteger (tick_factor * magic_multiplier)) + `div` 100) + where + tick_factor = te_tick_factor cfg + base_size = 100 + magic_multiplier = 40 + -- MAGIC NUMBER, multiplies the simplTickFactor + -- We can afford to be generous; this is really + -- just checking for loops, and shouldn't usually fire + -- A figure of 20 was too small: see #5539. + +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} +{-# INLINE mapSmpl #-} + +instance Functor SimplM where + fmap = mapSmpl + +instance Applicative SimplM where + pure = returnSmpl + (<*>) = ap + (*>) = thenSmpl_ + +instance Monad SimplM where + (>>) = (*>) + (>>=) = thenSmpl + +mapSmpl :: (a -> b) -> SimplM a -> SimplM b +mapSmpl f m = thenSmpl m (returnSmpl . f) + +returnSmpl :: a -> SimplM a +returnSmpl e = SM (\_st_env sc -> return (e, sc)) + +thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b +thenSmpl_ :: SimplM a -> SimplM b -> SimplM b + +thenSmpl m k + = SM $ \st_env sc0 -> do + (m_result, sc1) <- unSM m st_env sc0 + unSM (k m_result) st_env sc1 + +thenSmpl_ m k + = SM $ \st_env sc0 -> do + (_, sc1) <- unSM m st_env sc0 + unSM k st_env sc1 + +-- TODO: this specializing is not allowed +-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} + +traceSmpl :: String -> SDoc -> SimplM () +traceSmpl herald doc + = do logger <- getLogger + liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) +{-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] + +{- +************************************************************************ +* * +\subsection{The unique supply} +* * +************************************************************************ +-} + +-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques +simplMask :: Char +simplMask = 's' + +instance MonadUnique SimplM where + getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask + getUniqueM = liftIO $ uniqFromMask simplMask + +instance HasLogger SimplM where + getLogger = gets st_logger + +instance MonadIO SimplM where + liftIO = liftIOWithEnv . const + +getSimplRules :: SimplM RuleEnv +getSimplRules = liftIOWithEnv st_read_ruleenv + +liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a +liftIOWithEnv m = SM (\st_env sc -> do + x <- m st_env + return (x, sc)) + +gets :: (SimplTopEnv -> a) -> SimplM a +gets f = liftIOWithEnv (return . f) + +newId :: FastString -> Mult -> Type -> SimplM Id +newId fs w ty = mkSysLocalOrCoVarM fs w ty + +-- | Make a join id with given type and arity but without call-by-value annotations. +newJoinId :: [Var] -> Type -> SimplM Id +newJoinId bndrs body_ty + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "$j") + join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] + arity = count isId bndrs + -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core + join_arity = length bndrs + details = JoinId join_arity Nothing + id_info = vanillaIdInfo `setArityInfo` arity +-- `setOccInfo` strongLoopBreaker + + ; return (mkLocalVar details name ManyTy join_id_ty id_info) } + +{- +************************************************************************ +* * +\subsection{Counting up what we've done} +* * +************************************************************************ +-} + +getSimplCount :: SimplM SimplCount +getSimplCount = SM (\_st_env sc -> return (sc, sc)) + +tick :: Tick -> SimplM () +tick t = SM (\st_env sc -> let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) + +checkedTick :: Tick -> SimplM () +-- Try to take a tick, but fail if too many +checkedTick t + = SM (\st_env sc -> + if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) + then throwGhcExceptionIO $ + PprProgramError "Simplifier ticks exhausted" (msg sc) + else let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) + where + msg sc = vcat + [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." + , space + , text "In addition try adjusting -funfolding-case-threshold=N and" + , text "-funfolding-case-scaling=N for the module in question." + , text "Using threshold=1 and scaling=5 should break most inlining loops." + , space + , text "If you need to increase the tick factor substantially, while also" + , text "adjusting unfolding parameters please file a bug report and" + , text "indicate the factor you needed." + , space + , text "If GHC was unable to complete compilation even" + <+> text "with a very large factor" + , text "(a thousand or more), please consult the" + <+> doubleQuotes (text "Known bugs or infelicities") + , text "section in the Users Guide before filing a report. There are a" + , text "few situations unlikely to occur in practical programs for which" + , text "simplifier non-termination has been judged acceptable." + , space + , pp_details sc + , pprSimplCount sc ] + pp_details sc + | hasDetailedCounts sc = empty + | otherwise = text "To see detailed counts use -ddump-simpl-stats" + + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t + = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), sc')) diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -0,0 +1,2783 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +The simplifier utilities +-} + + + +module GHC.Core.Opt.Simplify.Utils ( + -- Rebuilding + rebuildLam, mkCase, prepareAlts, + tryEtaExpandRhs, wantEtaExpansion, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + updModeForStableUnfoldings, updModeForRules, + + -- The BindContext type + BindContext(..), bindContextLevel, + + -- The continuation type + SimplCont(..), DupFlag(..), StaticEnv, + isSimplified, contIsStop, + contIsDupable, contResultType, contHoleType, contHoleScaling, + contIsTrivial, contArgs, contIsRhs, + countArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo, + addValArgTo, addCastTo, addTyArgTo, + argInfoExpr, argInfoAppArgs, + pushSimplifiedArgs, pushSimplifiedRevArgs, + isStrictArgInfo, lazyArgContext, + + abstractFloats, + + -- Utilities + isExitJoinId + ) where + +import GHC.Prelude hiding (head, init, last, tail) + +import GHC.Core +import GHC.Types.Literal ( isLitRubbish ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Stats ( Tick(..) ) +import qualified GHC.Core.Subst +import GHC.Core.Ppr +import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Rules( RuleEnv, getRules ) +import GHC.Core.Opt.Arity +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity +import GHC.Core.Opt.ConstantFold + +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Tickish +import GHC.Types.Demand +import GHC.Types.Var.Set +import GHC.Types.Basic + +import GHC.Data.OrdList ( isNilOL ) +import GHC.Data.FastString ( fsLit ) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain + +import Control.Monad ( when ) +import Data.List ( sortBy ) +import qualified Data.List as Partial ( head ) + +{- ********************************************************************* +* * + The BindContext type +* * +********************************************************************* -} + +-- What sort of binding is this? A let-binding or a join-binding? +data BindContext + = BC_Let -- A regular let-binding + TopLevelFlag RecFlag + + | BC_Join -- A join point with continuation k + RecFlag -- See Note [Rules and unfolding for join points] + SimplCont -- in GHC.Core.Opt.Simplify + +bindContextLevel :: BindContext -> TopLevelFlag +bindContextLevel (BC_Let top_lvl _) = top_lvl +bindContextLevel (BC_Join {}) = NotTopLevel + +bindContextRec :: BindContext -> RecFlag +bindContextRec (BC_Let _ rec_flag) = rec_flag +bindContextRec (BC_Join rec_flag _) = rec_flag + +isJoinBC :: BindContext -> Bool +isJoinBC (BC_Let {}) = False +isJoinBC (BC_Join {}) = True + + +{- ********************************************************************* +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- ^ Stop[e] = e + OutType -- ^ Type of the + CallCtxt -- ^ Tells if there is something interesting about + -- the syntactic context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + SubDemand -- ^ The evaluation context of e. Tells how e is evaluated. + -- This fuels eta-expansion or eta-reduction without looking + -- at lambda bodies, for example. + -- + -- See Note [Eta reduction based on evaluation context] + -- The evaluation context for other SimplConts can be + -- reconstructed with 'contEvalContext' + + + | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] + OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + SimplCont + + | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_arg :: InExpr -- The argument, + , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] + { sc_arg_ty :: OutType -- Argument type + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_cont :: SimplCont } + + | Select -- (Select alts K)[e] = K[ case e of alts ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId -- case binder + , sc_alts :: [InAlt] -- Alternatives + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] + -- or, equivalently, = K[ (\x.b) e ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId + , sc_body :: InExpr + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] + { sc_dup :: DupFlag -- Always Simplified or OkToDup + , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus demands and discount flags for *this* arg + -- and further args + -- So ai_dmds and ai_discs are never empty + , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), + -- presumably (arg_ty -> res_ty) + -- where res_ty is expected by sc_cont + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] + CoreTickish -- Tick tickish + SimplCont + +type StaticEnv = SimplEnv -- Just the static part is relevant + +-- See Note [DupFlag invariants] +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- Note [StaticEnv invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pair up an InExpr or InAlts with a StaticEnv, which establishes the +lexical scope for that InExpr. + +When we simplify that InExpr/InAlts, we use + - Its captured StaticEnv + - Overriding its InScopeSet with the larger one at the + simplification point. + +Why override the InScopeSet? Example: + (let y = ey in f) ex +By the time we simplify ex, 'y' will be in scope. + +However the InScopeSet in the StaticEnv is not irrelevant: it should +include all the free vars of applying the substitution to the InExpr. +Reason: contHoleType uses perhapsSubstTy to apply the substitution to +the expression, and that (rightly) gives ASSERT failures if the InScopeSet +isn't big enough. + +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k} + and Select { se_dup = dup, se_env = env, se_cont = k} +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty, + or at least is always ignored; the payload is + already an OutThing +-} + +instance Outputable DupFlag where + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" + +instance Outputable SimplCont where + ppr (Stop ty interesting eval_sd) + = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty + where + pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd] + ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont + ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont + ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) + = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty) + 2 (pprParendExpr arg)) + $$ ppr cont + ppr (StrictBind { sc_bndr = b, sc_cont = cont }) + = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg { sc_fun = ai, sc_cont = cont }) + = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont + ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = (text "Select" <+> ppr dup <+> ppr bndr) $$ + whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = ArgInfo { + ai_fun :: OutId, -- The function + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + + ai_rewrite :: RewriteCall, -- What transformation to try next for this call + -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + + ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) + -- non-zero => be keener to inline + -- Always infinite + } + +data RewriteCall -- What rewriting to try next for this call + -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration + = TryRules FullArgCount [CoreRule] + | TryInlining + | TryNothing + +data ArgSpec + = ValArg { as_dmd :: Demand -- Demand placed on this argument + , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) + + | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy + , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) + + | CastBy OutCoercion -- Cast by this; c.f. CastIt + +instance Outputable ArgInfo where + ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds }) + = text "ArgInfo" <+> braces + (sep [ text "fun =" <+> ppr fun + , text "dmds(first 10) =" <+> ppr (take 10 dmds) + , text "args =" <+> ppr args ]) + +instance Outputable ArgSpec where + ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + ppr (CastBy c) = text "CastBy" <+> ppr c + +addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo +addValArgTo ai arg hole_ty + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rewrite = rew } <- ai + -- Pop the top demand and and discounts off + , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } + = ai { ai_args = arg_spec : ai_args ai + , ai_dmds = dmds + , ai_discs = discs + , ai_rewrite = decArgCount rew } + | otherwise + = pprPanic "addValArgTo" (ppr ai $$ ppr arg) + -- There should always be enough demands and discounts + +addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo +addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai + , ai_rewrite = decArgCount (ai_rewrite ai) } + where + arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } + +isStrictArgInfo :: ArgInfo -> Bool +-- True if the function is strict in the next argument +isStrictArgInfo (ArgInfo { ai_dmds = dmds }) + | dmd:_ <- dmds = isStrUsedDmd dmd + | otherwise = False + +argInfoAppArgs :: [ArgSpec] -> [OutExpr] +argInfoAppArgs [] = [] +argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast +argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as +argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as + +pushSimplifiedArgs, pushSimplifiedRevArgs + :: SimplEnv + -> [ArgSpec] -- In normal, forward order for pushSimplifiedArgs, + -- in /reverse/ order for pushSimplifiedRevArgs + -> SimplCont -> SimplCont +pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args +pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args + +pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont +pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont + = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } +pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont + = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified + -- The SubstEnv will be ignored since sc_dup=Simplified + , sc_hole_ty = hole_ty, sc_cont = cont } +pushSimplifiedArg _ (CastBy c) cont = CastIt c cont + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + go [] = Var fun + go (ValArg { as_arg = arg } : as) = go as `App` arg + go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty + go (CastBy co : as) = mkCast (go as) co + +decArgCount :: RewriteCall -> RewriteCall +decArgCount (TryRules n rules) = TryRules (n-1) rules +decArgCount rew = rew + +mkRewriteCall :: Id -> RuleEnv -> RewriteCall +-- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration +-- We try to skip any unnecessary stages: +-- No rules => skip TryRules +-- No unfolding => skip TryInlining +-- This skipping is "just" for efficiency. But rebuildCall is +-- quite a heavy hammer, so skipping stages is a good plan. +-- And it's extremely simple to do. +mkRewriteCall fun rule_env + | not (null rules) = TryRules n_required rules + | canUnfold unf = TryInlining + | otherwise = TryNothing + where + n_required = maximum (map ruleArity rules) + rules = getRules rule_env fun + unf = idUnfolding fun + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt topSubDmd + +mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont +-- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd) + +mkLazyArgStop :: OutType -> ArgInfo -> SimplCont +mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd + where + arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + +------------------- +contIsRhs :: SimplCont -> Maybe RecFlag +contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec +contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context +contIsRhs _ = Nothing + +------------------- +contIsStop :: SimplCont -> Bool +contIsStop (Stop {}) = True +contIsStop _ = False + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] +contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (CastIt _ k) = contIsDupable k +contIsDupable _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k +-- This one doesn't look right. A value application is not trivial +-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +contIsTrivial (CastIt _ k) = contIsTrivial k +contIsTrivial _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _ _) = ty +contResultType (CastIt _ k) = contResultType k +contResultType (StrictBind { sc_cont = k }) = contResultType k +contResultType (StrictArg { sc_cont = k }) = contResultType k +contResultType (Select { sc_cont = k }) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _ _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt co _) = coercionLKind co +contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) + = perhapsSubstTy dup se (idType b) +contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) + = perhapsSubstTy d se (idType b) + + +-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of +-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling +-- factor is p. And in E[G[]], the scaling factor is the product of the scaling +-- factor of E and that of G. +-- +-- The scaling factor at the hole of E[] is used to determine how a binder +-- should be scaled if it commutes with E. This appears, in particular, in the +-- case-of-case transformation. +contHoleScaling :: SimplCont -> Mult +contHoleScaling (Stop _ _ _) = OneTy +contHoleScaling (CastIt _ k) = contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) + = w `mkMultMul` contHoleScaling k + where + (w, _, _) = splitFunTy fun_ty +contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k +contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k +contHoleScaling (TickIt _ k) = contHoleScaling k + +------------------- +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, +-- and other values; skipping over casts. +countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont +countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs (CastIt _ cont) = countArgs cont +countArgs _ = 0 + +countValArgs :: SimplCont -> Int +-- Count value arguments only +countValArgs (ApplyToTy { sc_cont = cont }) = 1 + countValArgs cont +countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont +countValArgs (CastIt _ cont) = countValArgs cont +countValArgs _ = 0 + +------------------- +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold + lone (ApplyToVal {}) = False -- NB: even a type application or cast + lone (CastIt {}) = False -- stops it being "lone" + lone _ = True + + go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) + = go (is_interesting arg se : args) k + go args (ApplyToTy { sc_cont = k }) = go args k + go args (CastIt _ k) = go args k + go args k = (False, reverse args, k) + + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + +-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'. +-- This can be more insightful than the limited syntactic context that +-- 'SimplCont' provides, because the 'Stop' constructor might carry a useful +-- 'SubDemand'. +-- For example, when simplifying the argument `e` in `f e` and `f` has the +-- demand signature ``, this function will give you back `P(S,A)` when +-- simplifying `e`. +-- +-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought +-- about what to do then and no call sites so far seem to care. +contEvalContext :: SimplCont -> SubDemand +contEvalContext k = case k of + (Stop _ _ sd) -> sd + (TickIt _ k) -> contEvalContext k + (CastIt _ k) -> contEvalContext k + ApplyToTy{sc_cont=k} -> contEvalContext k + -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k + -- Not 100% sure that's correct, . Here's an example: + -- f (e x) and f :: + -- then what is the evaluation context of 'e' when we simplify it? E.g., + -- simpl e (ApplyToVal x $ Stop "C(S,C(1,L))") + -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all. + -- But for now we just panic: + ApplyToVal{} -> pprPanic "contEvalContext" (ppr k) + StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr) + Select{} -> topSubDmd + -- Perhaps reconstruct the demand on the scrutinee by looking at field + -- and case binder dmds, see addCaseBndrDmd. No priority right now. + +------------------- +mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo + +mkArgInfo env rule_base fun cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [] + , ai_rewrite = fun_rewrite + , ai_encl = False + , ai_dmds = vanilla_dmds + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun + , ai_args = [] + , ai_rewrite = fun_rewrite + , ai_encl = fun_has_rules || contHasRules cont + , ai_dmds = add_type_strictness (idType fun) arg_dmds + , ai_discs = arg_discounts } + where + n_val_args = countValArgs cont + fun_rewrite = mkRewriteCall fun rule_base + fun_has_rules = case fun_rewrite of + TryRules {} -> True + _ -> False + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds = repeat topDmd + + arg_dmds + | not (seInline env) + = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] + | otherwise + = -- add_type_str fun_ty $ + case splitDmdSig (idDmdSig fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then + demands -- Finite => result is bottom + else + demands ++ vanilla_dmds + | otherwise + -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands) $ + vanilla_dmds -- Not enough args, or no strictness + + add_type_strictness :: Type -> [Demand] -> [Demand] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_strictness is done repeatedly (for each call); + -- might be better once-for-all in the function + -- But beware primops/datacons with no strictness + + add_type_strictness fun_ty dmds + | null dmds = [] + + | 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 + , dmd : rest_dmds <- dmds + , let dmd' + | Just Unlifted <- typeLevity_maybe arg_ty + = strictifyDmd dmd + | otherwise + -- Something that's not definitely unlifted. + -- If the type is representation-polymorphic, we can't know whether + -- it's strict. + = dmd + = dmd' : add_type_strictness fun_ty' rest_dmds + + | otherwise + = dmds + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in + +Note [Do not expose strictness if sm_inline=False] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#15163 showed a case in which we had + + {-# INLINE [1] zip #-} + zip = undefined + + {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} + +If we expose zip's bottoming nature when simplifying the LHS of the +RULE we get + {-# RULES "foo" forall as bs. + stream (case zip of {}) = ..blah... #-} +discarding the arguments to zip. Usually this is fine, but on the +LHS of a rule it's not, because 'as' and 'bs' are now not bound on +the LHS. + +This is a pretty pathological example, so I'm not losing sleep over +it, but the simplest solution was to check sm_inline; if it is False, +which it is on the LHS of a rule (see updModeForRules), then don't +make use of the strictness info for the function. +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee that isn't just a seq, application etc.) +then we inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +Note [No case of case is boring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + case f x of + +we'd usually treat the context as interesting, to encourage 'f' to +inline. But if case-of-case is off, it's really not so interesting +after all, because we are unlikely to be able to push the case +expression into the branches of any case in f's unfolding. So, to +reduce unnecessary code expansion, we just make the context look boring. +This made a small compile-time perf improvement in perf/compiler/T6048, +and it looks plausible to me. + +Note [Seq is boring] +~~~~~~~~~~~~~~~~~~~~ +Suppose + f x = case v of + True -> Just x + False -> Just (x-1) + +Now consider these cases: + +1. case f x of b{-dead-} { DEFAULT -> blah[no b] } + Inlining (f x) will allow us to avoid ever allocating (Just x), + since the case binder `b` is dead. We will end up with a + join point for blah, thus + join j = blah in + case v of { True -> j; False -> j } + which will turn into (case v of DEFAULT -> blah + All good + +2. case f x of b { DEFAULT -> blah[b] } + Inlining (f x) will still mean we allocate (Just x). We'd get: + join j b = blah[b] + case v of { True -> j (Just x); False -> j (Just (x-1)) } + No new optimisations are revealed. Nothing is gained. + (This is the situation in T22317.) + +2a. case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] } + Instead of DEFAULT we have a single constructor alternative + with all dead binders. This is just a variant of (2); no + gain from inlining (f x) + +3. case f x of b { Just y -> blah[y,b] } + Inlining (f x) will mean we still allocate (Just x), + but we also get to bind `y` without fetching it out of the Just, thus + join j y b = blah[y,b] + case v of { True -> j x (Just x) + ; False -> let y = x-1 in j y (Just y) } + Inlining (f x) has a small benefit, perhaps. + (To T14955 it makes a surprisingly large difference of ~30% to inline here.) + + +Conclusion: if the case expression + * Has a non-dead case-binder + * Has one alternative + * All the binders in the alternative are dead +then the `case` is just a strict let-binding, and the scrutinee is +BoringCtxt (don't inline). Otherwise CaseCtxt. +-} + +lazyArgContext :: ArgInfo -> CallCtxt +-- Use this for lazy arguments +lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +strictArgContext :: ArgInfo -> CallCtxt +strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) +-- Use this for strict arguments + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive + -- Why RhsCtxt? if we see f (g x), and f is strict, we + -- want to be a bit more eager to inline g, because it may + -- expose an eval (on x perhaps) that can be eliminated or + -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 + -- It's worth an 18% improvement in allocation for this + -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + -- + -- Why NonRecursive? Becuase it's a bit like + -- let a = g x in f a + +interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext env cont + = interesting cont + where + interesting (Select {sc_alts=alts, sc_bndr=case_bndr}) + | not (seCaseCase env) = BoringCtxt -- See Note [No case of case is boring] + | [Alt _ bs _] <- alts + , all isDeadBinder bs + , not (isDeadBinder case_bndr) = BoringCtxt -- See Note [Seq is boring] + | otherwise = CaseCtxt + + + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in GHC.Core.Unfold + + interesting (StrictArg { sc_fun = fun }) = strictArgContext fun + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci _) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt _ k) = interesting k + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +contHasRules :: SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f. So contHasRules +-- tries to see if the context of the f-call is a call to a function +-- with rules. +-- +-- The ai_encl flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +contHasRules cont + = go cont + where + go (ApplyToVal { sc_cont = cont }) = go cont + go (ApplyToTy { sc_cont = cont }) = go cont + go (CastIt _ cont) = go cont + go (StrictArg { sc_fun = fun }) = ai_encl fun + go (Stop _ RuleArgCtxt _) = True + go (TickIt _ c) = go c + go (Select {}) = False + go (StrictBind {}) = False -- ?? + go (Stop _ _ _) = False + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + = case substId env v of + DoneId v' -> go_var n v' + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit l) + | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 + | otherwise = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + env' = env `addNewInScopeIds` bindersOf b + + go_var n v + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] + | otherwise = TrivArg -- n==0, no useful unfolding + where + conlike_unfolding = isConLikeUnfolding (idUnfolding v) + +{- +************************************************************************ +* * + SimplMode +* * +************************************************************************ +-} + +updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [The environments of the Simplify pass] +updModeForStableUnfoldings unf_act current_mode + = current_mode { sm_phase = phaseFromActivation unf_act + , sm_eta_expand = False + , sm_inline = True } + -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules] + -- sm_rules: just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplMode -> SimplMode +-- See Note [Simplifying rules] +-- See Note [The environments of the Simplify pass] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False + -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_cast_swizzle = False + -- See Note [Cast swizzling on rule LHSs] + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule LHS, refrain from /any/ inlining or applying +of other RULES. Doing anything to the LHS is plain confusing, because +it means that what the rule matches is not what the user +wrote. c.f. #10595, and #10528. + +* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks + introducing Ticks into the LHS, which makes matching + trickier. #10665, #10745. + + Doing this to either side confounds tools like HERMIT, which seek to reason + about and apply the RULES as originally written. See #10829. + + See also Note [Do not expose strictness if sm_inline=False] + +* sm_eta_expand: the template (LHS) of a rule must only mention coercion + /variables/ not arbitrary coercions. See Note [Casts in the template] in + GHC.Core.Rules. Eta expansion can create new coercions; so we switch + it off. + +There is, however, one case where we are pretty much /forced/ to transform the +LHS of a rule: postInlineUnconditionally. For instance, in the case of + + let f = g @Int in f + +We very much want to inline f into the body of the let. However, to do so (and +be able to safely drop f's binding) we must inline into all occurrences of f, +including those in the LHS of rules. + +This can cause somewhat surprising results; for instance, in #18162 we found +that a rule template contained ticks in its arguments, because +postInlineUnconditionally substituted in a trivial expression that contains +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +details. + +Note [Cast swizzling on rule LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the LHS of a RULE we may have + (\x. blah |> CoVar cv) +where `cv` is a coercion variable. Critically, we really only want +coercion /variables/, not general coercions, on the LHS of a RULE. So +we don't want to swizzle this to + (\x. blah) |> (Refl xty `FunCo` CoVar cv) +So we switch off cast swizzling in updModeForRules. + +Note [Eta expansion in stable unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SPJ Jul 22: whether or not eta-expansion is switched on in a stable +unfolding, or the RHS of a RULE, seems to be a bit moot. But switching +it on adds clutter, so I'm experimenting with switching off +eta-expansion in such places. + +In the olden days, we really /wanted/ to switch it off. + + Old note: If we have a stable unfolding + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + we do not want to eta-expand to + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + because now specialisation of the overloading doesn't work properly + (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + So we disable eta-expansion in stable unfoldings. + +But this old note is no longer relevant because the specialiser has +improved: see Note [Account for casts in binding] in +GHC.Core.Opt.Specialise. So we seem to have a free choice. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating + e.g. ...(case f x of ...)... + ==> ...(case (case x of I# x# -> fw x#) of ...)... + ==> ...(case x of I# x# -> case fw x# of ...)... +and now the redex (f x) isn't floatable any more. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of a stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +continuation. +-} + +activeUnfolding :: SimplMode -> Id -> Bool +activeUnfolding mode id + | isCompulsoryUnfolding (realIdUnfolding id) + = True -- Even sm_inline can't override compulsory unfoldings + | otherwise + = isActive (sm_phase mode) (idInlineActivation id) + && sm_inline mode + -- `or` isStableUnfolding (realIdUnfolding id) + -- Inline things when + -- (a) they are active + -- (b) sm_inline says so, except that for stable unfoldings + -- (ie pragmas) we inline anyway + +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv +-- When matching in RULE, we want to "look through" an unfolding +-- (to see a constructor) if *rules* are on, even if *inlinings* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = ISE in_scope id_unf + where + in_scope = seInScope env + phase = sePhase env + id_unf = whenActiveUnfoldingFun (isActive phase) + -- When sm_rules was off we used to test for a /stable/ unfolding, + -- but that seems wrong (#20941) + +---------------------- +activeRule :: SimplMode -> Activation -> Bool +-- Nothing => No rules at all +activeRule mode + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrence of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until FinalPhase (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the initial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of fInt. But if we inline it there +it might make fInt look big, and we'll lose the opportunity to inline f +at each of fInt's call sites. The INLINE pragma will only inline when +the application is saturated for exactly this reason; and we don't +want PreInlineUnconditionally to second-guess it. A live example is #3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +NB: this only applies for INLINE things. Do /not/ switch off +preInlineUnconditionally for + +* INLINABLE. It just says to GHC "inline this if you like". If there + is a unique occurrence, we want to inline the stable unfolding, not + the RHS. + +* NONLINE[n] just switches off inlining until phase n. We should + respect that, but after phase n, just behave as usual. + +* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers. + (See #18815.) + +Note [Top-level bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally + :: SimplEnv -> TopLevelFlag -> InId + -> InExpr -> StaticEnv -- These two go together + -> Maybe SimplEnv -- Returned env has extended substitution +-- Precondition: rhs satisfies the let-can-float invariant +-- See Note [Core let-can-float invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +preInlineUnconditionally env top_lvl bndr rhs rhs_env + | not pre_inline_unconditionally = Nothing + | not active = Nothing + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] + -- in module Exitify + | not (one_occ (idOccInfo bndr)) = Nothing + | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs) + + -- See Note [Stable unfoldings and preInlineUnconditionally] + | not (isInlinePragma inline_prag) + , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + | otherwise = Nothing + where + unf = idUnfolding bndr + extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + pre_inline_unconditionally = sePreInline env + active = isActive (sePhase env) (inlinePragmaActivation inline_prag) + -- See Note [pre/postInlineUnconditionally in gentle mode] + inline_prag = idInlinePragma bndr + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = sePhase env /= FinalPhase + -- If we don't have this early_phase test, consider + -- x = length [1,2,3] + -- The full laziness pass carefully floats all the cons cells to + -- top level, and preInlineUnconditionally floats them all back in. + -- Result is (a) static allocation replaced by dynamic allocation + -- (b) many simplifier iterations because this tickles + -- a related problem; only one inlining per pass + -- + -- On the other hand, I have seen cases where top-level fusion is + -- lost if we don't inline top level thing (e.g. string constants) + -- Hence the test for phase zero (which is the phase for all the final + -- simplifications). Until phase zero we take no special notice of + -- top level things, but then we become more leery about inlining + -- them. + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +occurrence(s) + +Note that we do this unconditional inlining only for trivial RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. + +NB: unconditional inlining of this sort can introduce ticks in places that +may seem surprising; for instance, the LHS of rules. See Note [Simplifying +rules] for details. +-} + +postInlineUnconditionally + :: SimplEnv -> BindContext + -> OutId -- The binder (*not* a CoVar), including its unfolding + -> OccInfo -- From the InId + -> OutExpr + -> Bool +-- Precondition: rhs satisfies the let-can-float invariant +-- See Note [Core let-can-float invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +postInlineUnconditionally env bind_cxt bndr occ_info rhs + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isTopLevel (bindContextLevel bind_cxt) + = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True + | BC_Join {} <- bind_cxt -- See point (1) of Note [Duplicating join points] + , not (phase == FinalPhase) = False -- in Simplify.hs + | otherwise + = case occ_info of + OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } + -- See Note [Inline small things to avoid creating a thunk] + + -> n_br < 100 -- See Note [Suppress exponential blowup] + + && smallEnoughToInline uf_opts unfolding -- Small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + -- + -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1 + -- Reason: doing so risks exponential behaviour. We simplify a big + -- expression, inline it, and simplify it again. But if the + -- very same thing happens in the big expression, we get + -- exponential cost! + -- PRINCIPLE: when we've already simplified an expression once, + -- make sure that we only inline it if it's reasonably small. + + && (in_lam == NotInsideLam || + -- Outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + (isCheapUnfolding unfolding && int_cxt == IsInteresting)) + -- isCheap => acceptable work duplication; in_lam may be true + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + + IAmDead -> True -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> False + +-- Here's an example that we don't handle well: +-- let f = if b then Left (\x.BIG) else Right (\y.BIG) +-- in \y. ....case f of {...} .... +-- Here f is used just once, and duplicating the case work is fine (exprIsCheap). +-- But +-- - We can't preInlineUnconditionally because that would invalidate +-- the occ info for b. +-- - We can't postInlineUnconditionally because the RHS is big, and +-- that risks exponential behaviour +-- - We can't call-site inline, because the rhs is big +-- Alas! + + where + unfolding = idUnfolding bndr + uf_opts = seUnfoldingOpts env + phase = sePhase env + active = isActive phase (idInlineActivation bndr) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- Note [Inline small things to avoid creating a thunk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The point of examining occ_info here is that for *non-values* that +occur outside a lambda, the call-site inliner won't have a chance +(because it doesn't know that the thing only occurs once). The +pre-inliner won't have gotten it either, if the thing occurs in more +than one branch So the main target is things like + + let x = f y in + case v of + True -> case x of ... + False -> case x of ... + +This is very important in practice; e.g. wheel-seive1 doubles +in allocation if you miss this out. And bits of GHC itself start +to allocate more. An egregious example is test perf/compiler/T14697, +where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. + +Note [Suppress exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13253, and several related tickets, we got an exponential blowup +in code size from postInlineUnconditionally. The trouble comes when +we have + let j1a = case f y of { True -> p; False -> q } + j1b = case f y of { True -> q; False -> p } + j2a = case f (y+1) of { True -> j1a; False -> j1b } + j2b = case f (y+1) of { True -> j1b; False -> j1a } + ... + in case f (y+10) of { True -> j10a; False -> j10b } + +when there are many branches. In pass 1, postInlineUnconditionally +inlines j10a and j10b (they are both small). Now we have two calls +to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines +all four of these calls, leaving four calls to j8a and j8b. Etc. +Yikes! This is exponential! + +A possible plan: stop doing postInlineUnconditionally +for some fixed, smallish number of branches, say 4. But that turned +out to be bad: see Note [Inline small things to avoid creating a thunk]. +And, as it happened, the problem with #13253 was solved in a +different way (Note [Duplicating StrictArg] in Simplify). + +So I just set an arbitrary, high limit of 100, to stop any +totally exponential behaviour. + +This still leaves the nasty possibility that /ordinary/ inlining (not +postInlineUnconditionally) might inline these join points, each of +which is individually quiet small. I'm still not sure what to do +about this (e.g. see #15488). + +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + + * The Id might be exported. We could check for that separately, + but since we aren't going to postInlineUnconditionally /any/ + top-level bindings, we don't need to test. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has a stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +rebuildLam :: SimplEnv + -> [OutBndr] -> OutExpr + -> SimplCont + -> SimplM OutExpr +-- (rebuildLam env bndrs body cont) +-- returns expr which means the same as \bndrs. body +-- +-- But it tries +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] +-- +-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set + +rebuildLam _env [] body _cont + = return body + +rebuildLam env bndrs@(bndr:_) body cont + = {-# SCC "rebuildLam" #-} try_eta bndrs body + where + rec_ids = seRecIds env + in_scope = getInScope env -- Includes 'bndrs' + mb_rhs = contIsRhs cont + + -- See Note [Eta reduction based on evaluation context] + eval_sd = contEvalContext cont + -- NB: cont is never ApplyToVal, because beta-reduction would + -- have happened. So contEvalContext can panic on ApplyToVal. + + try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr + try_eta bndrs body + | -- Try eta reduction + seDoEtaReduction env + , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd + = do { tick (EtaReduction bndr) + ; return etad_lam } + + | -- Try eta expansion + Nothing <- mb_rhs -- See Note [Eta expanding lambdas] + , seEtaExpand env + , any isRuntimeVar bndrs -- Only when there is at least one value lambda already + , Just body_arity <- exprEtaExpandArity (seArityOpts env) body + = do { tick (EtaExpansion bndr) + ; let body' = etaExpandAT in_scope body_arity body + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body + , text "after" <+> ppr body']) + -- NB: body' might have an outer Cast, but if so + -- mk_lams will pull it further out, past 'bndrs' to the top + ; return (mk_lams bndrs body') } + + | otherwise + = return (mk_lams bndrs body) + + mk_lams :: [OutBndr] -> OutExpr -> OutExpr + -- mk_lams pulls casts and ticks to the top + mk_lams bndrs body@(Lam {}) + = mk_lams (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mk_lams bndrs (Tick t expr) + | tickishFloatable t + = mkTick t (mk_lams bndrs expr) + + mk_lams bndrs (Cast body co) + | -- Note [Casts and lambdas] + seCastSwizzle env + , not (any bad bndrs) + = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co) + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mk_lams bndrs body + = mkLams bndrs body + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:tx). (\(y:ty). e) `cast` co) + +We float the cast out, thus + (\(x:tx) (y:ty). e) `cast` (tx -> co) + +We do this for at least three reasons: + +1. There is a danger here that the two lambdas look separated, and the + full laziness pass might float an expression to between the two. + +2. The occurrence analyser will mark x as InsideLam if the Lam nodes + are separated (see the Lam case of occAnal). By floating the cast + out we put the two Lams together, so x can get a vanilla Once + annotation. If this lambda is the RHS of a let, which we inline, + we can do preInlineUnconditionally on that x=arg binding. With the + InsideLam OccInfo, we can't do that, which results in an extra + iteration of the Simplifier. + +3. It may cancel with another cast. E.g + (\x. e |> co1) |> co2 + If we float out co1 it might cancel with co2. Similarly + let f = (\x. e |> co1) in ... + If we float out co1, and then do cast worker/wrapper, we get + let f1 = \x.e; f = f1 |> co1 in ... + and now we can inline f, hoping that co1 may cancel at a call site. + +TL;DR: put the lambdas together if at all possible. + +In general, here's the transformation: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +We call this "cast swizzling". It is controlled by sm_cast_swizzle. +See also Note [Cast swizzling on rule LHSs] + +Wrinkles + +* Notice that it works regardless of 'e'. Originally it worked only + if 'e' was itself a lambda, but in some cases that resulted in + fruitless iteration in the simplifier. A good example was when + compiling Text.ParserCombinators.ReadPrec, where we had a definition + like (\x. Get `cast` g) + where Get is a constructor with nonzero arity. Then mkLam eta-expanded + the Get, and the next iteration eta-reduced it, and then eta-expanded + it again. + +* Note also the side condition for the case of coercion binders, namely + not (any bad bndrs). It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) + because the latter is not well-kinded. + + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr + -> SimplM (ArityType, OutExpr) +-- See Note [Eta-expanding at let bindings] +tryEtaExpandRhs env bind_cxt bndr rhs + | do_eta_expand -- If the current manifest arity isn't enough + -- (never true for join points) + , seEtaExpand env -- and eta-expansion is on + , wantEtaExpansion rhs + = -- Do eta-expansion. + assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $ + -- assert: this never happens for join points; see GHC.Core.Opt.Arity + -- Note [Do not eta-expand join points] + do { tick (EtaExpansion bndr) + ; return (arity_type, etaExpandAT in_scope arity_type rhs) } + + | otherwise + = return (arity_type, rhs) + + where + in_scope = getInScope env + arity_opts = seArityOpts env + is_rec = bindContextRec bind_cxt + (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs + +wantEtaExpansion :: CoreExpr -> Bool +-- Mostly True; but False of PAPs which will immediately eta-reduce again +-- See Note [Which RHSs do we eta-expand?] +wantEtaExpansion (Cast e _) = wantEtaExpansion e +wantEtaExpansion (Tick _ e) = wantEtaExpansion e +wantEtaExpansion (Lam b e) | isTyVar b = wantEtaExpansion e +wantEtaExpansion (App e _) = wantEtaExpansion e +wantEtaExpansion (Var {}) = False +wantEtaExpansion (Lit {}) = False +wantEtaExpansion _ = True + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Which RHSs do we eta-expand?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand: + +* Trivial RHSs, e.g. f = g + If we eta expand do + f = \x. g x + we'll just eta-reduce again, and so on; so the + simplifier never terminates. + +* PAPs: see Note [Do not eta-expand PAPs] + +What about things like this? + f = case y of p -> \x -> blah + +Here we do eta-expand. This is a change (Jun 20), but if we have +really decided that f has arity 1, then putting that lambda at the top +seems like a Good idea. + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand to + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G before, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +Moreover, if we eta expand + f = g d ==> f = \x. g d x +that might in turn make g inline (if it has an inline pragma), which +we might not want. After all, INLINE pragmas say "inline only when +saturated" so we don't want to be too gung-ho about saturating! + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in +GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing +in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Several points worth noting + +(AB1) The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + +(AB2) We must do closeOverKinds. Example (#10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. + +(AB3) We get the variables to abstract over by filtering down the + the main_tvs for the original function, picking only ones + mentioned in the abstracted body. This means: + - they are automatically in dependency order, because main_tvs is + - there is no issue about non-determinism + - we don't gratuitously change order, which may help (in a tiny + way) with CSE and/or the compiler-debugging experience + +(AB4) For a recursive group, it's a bit of a pain to work out the minimal + set of tyvars over which to abstract: + /\ a b c. let x = ...a... in + letrec { p = ...x...q... + q = .....p...b... } in + ... + Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + Remember this bizarre case too: + x::a = x + Here, we must abstract 'x' over 'a'. + + Why is it worth doing this? Partly tidiness; and partly #22459 + which showed that it's harder to do polymorphic specialisation well + if there are dictionaries abstracted over unnecessary type variables. + See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise +-} + +abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats + -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats uf_opts top_lvl main_tvs floats body + = assert (notNull body_floats) $ + assert (isNilOL (sfJoinFloats floats)) $ + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + ; return (float_binds, GHC.Core.Subst.substExpr subst body) } + where + is_top_lvl = isTopLevel top_lvl + body_floats = letFloatBinds (sfLetFloats floats) + empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) + + abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) + abstract subst (NonRec id rhs) + = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id + ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' + !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app + ; return (subst', NonRec poly_id2 poly_rhs) } + where + rhs' = GHC.Core.Subst.substExpr subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') + + abstract subst (Rec prs) + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids + ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) + poly_pairs = [ mk_poly2 poly_id tvs_here rhs' + | (poly_id, rhs) <- poly_ids `zip` rhss + , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] + ; return (subst', Rec poly_pairs) } + where + (ids,rhss) = unzip prs + + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs) + + -- See wrinkle (AB4) in Note [Which type variables to abstract over] + get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs + get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs) + + get_tvs :: Var -> VarSet -> VarSet + get_tvs var free_tvs + | isTyVar var -- CoVars have been substituted away + = extendVarSet free_tvs var + | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var + = -- 'var' is like 'x' in (AB4) + exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs + | otherwise + = free_tvs + + choose_tvs free_tvs + = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3) + where + all_free_tvs = closeOverKinds free_tvs -- (AB2) + + mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) + mk_poly1 tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id + mkLocalId poly_name (idMult var) poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + + mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) + mk_poly2 poly_id tvs_here rhs + = (poly_id `setIdUnfolding` unf, poly_rhs) + where + poly_rhs = mkLams tvs_here rhs + unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing + + -- We want the unfolding. Consider + -- let + -- x = /\a. let y = ... in Just y + -- in body + -- Then we float the y-binding out (via abstractFloats and addPolyBind) + -- but 'x' may well then be inlined in 'body' in which case we'd like the + -- opportunity to inline 'y' too. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs + +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + See GHC.Core.Utils Note [Refine DEFAULT case alternatives] + +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts + +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! + +Note [Shadowing in prepareAlts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an +/OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build +a new /InAlt/. If you pass an OutId, we'll end up appling the +substitution twice: disaster (#23012). + +However this does mean that filling in the default alt might be +delayed by a simplifier cycle, because an InId has less info than an +OutId. Test simplCore/should_compile/simpl013 apparently shows this +up, although I'm not sure exactly how.. +-} + +prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +-- +-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts] +prepareAlts scrut case_bndr alts + | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr) + = do { us <- getUniquesM + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1 + -- The multiplicity on case_bndr's is the multiplicity of the + -- case expression The newly introduced patterns in + -- refineDefaultAlt must be scaled by this multiplicity + (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 + -- "idcs" stands for "impossible default data constructors" + -- i.e. the constructors that can't match the default case + ; when yes2 $ tick (FillInCaseDefault case_bndr) + ; when yes3 $ tick (AltMerge case_bndr) + ; return (idcs3, alts3) } + + | otherwise -- Not a data type, so nothing interesting happens + = return ([], alts) + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +mkCase tries these things + +* Note [Merge Nested Cases] +* Note [Eliminate Identity Case] +* Note [Scrutinee Constant Folding] + +Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + +which merges two cases in one case when -- the default alternative of +the outer case scrutinises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +Note [Eliminate Identity Case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of ===> e + True -> True; + False -> False + +and similar friends. + +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case x op# k# of _ { ===> case x of _ { + a1# -> e1 (a1# inv_op# k#) -> e1 + a2# -> e2 (a2# inv_op# k#) -> e2 + ... ... + DEFAULT -> ed DEFAULT -> ed + + where (x op# k#) inv_op# k# == x + +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAULT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles. + +Wrinkle 1: + Do not apply caseRules if there is just a single DEFAULT alternative, + unless the case-binder is dead. Example: + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case e of b' { DEFAULT -> let b = b' +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. But if the original case binder b is dead, we instead get + case e of b' { DEFAULT -> rhs } + and there is no such problem. + + See Note [Example of case-merging and caseRules] for a compelling + example of why this dead-binder business can be really important. + + +Wrinkle 2: + The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +Wrinkle 3: + The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +Wrinkle 4: + In dataToTag we might need to make up some fake binders; + see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + + + +Note [Example of case-merging and caseRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The case-transformation rules are quite powerful. Here's a +subtle example from #22375. We start with + + data T = A | B | ... + deriving Eq + + f :: T -> String + f x = if | x==A -> "one" + | x==B -> "two" + | ... + +In Core after a bit of simplification we get: + + f x = case dataToTag# x of a# { _DEFAULT -> + case a# of + _DEFAULT -> case dataToTag# x of b# { _DEFAULT -> + case b# of + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now consider what mkCase does to these case expressions. +The case-merge transformation Note [Merge Nested Cases] +does this (affecting both pairs of cases): + + f x = case dataToTag# x of a# { + _DEFAULT -> case dataToTag# x of b# { + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now Note [caseRules for dataToTag] does its work, again +on both dataToTag# cases: + + f x = case x of x1 { + _DEFAULT -> case dataToTag# x1 of a# { _DEFAULT -> + case x of x2 { + _DEFAULT -> case dataToTag# x2 of b# { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + + +The new dataToTag# calls come from the "reconstruct scrutinee" part of +caseRules (note that a# and b# were not dead in the original program +before all this merging). However, since a# and b# /are/ in fact dead +in the resulting program, we are left with redundant dataToTag# calls. +But they are easily eliminated by doing caseRules again, in +the next Simplifier iteration, this time noticing that a# and b# are +dead. Hence the "dead-binder" sub-case of Wrinkle 1 of Note +[Scrutinee Constant Folding] above. Once we do this we get + + f x = case x of x1 { + _DEFAULT -> case x1 of x2 { _DEFAULT -> + case x1 of x2 { + _DEFAULT -> case x2 of x3 { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + +and now we can do case-merge again, getting the desired + + f x = case x of + A -> "one" + B -> "two" + ... + +-} + +mkCase, mkCase1, mkCase2, mkCase3 + :: SimplMode + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-------------------------------------------------- + +mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) + | sm_case_merge mode + , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) + <- stripTicksTop tickishFloatable deflt_rhs + , inner_scrut_var == outer_bndr + = do { tick (CaseMerge outer_bndr) + + ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args) + (Alt con args (wrap_rhs rhs)) + -- Simplifier's no-shadowing invariant should ensure + -- that outer_bndr is not shadowed by the inner patterns + wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs + -- The let is OK even for unboxed binders, + + wrapped_alts | isDeadBinder inner_bndr = inner_alts + | otherwise = map wrap_alt inner_alts + + merged_alts = mergeAlts outer_alts wrapped_alts + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + + ; fmap (mkTicks ticks) $ + mkCase1 mode scrut outer_bndr alts_ty merged_alts + } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + +mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' + identity_alt (Alt con args rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args -- See Note [RHS casts] + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + check_eq (Tick t e) alt args + = tickishFloatable t && check_eq e alt args + + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) args + | null arg_tys, null args = v == dataConWorkId con + -- Optimisation only + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + check_eq _ _ _ = False + + arg_tys = tyConAppArgs (idType case_bndr) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Scrutinee Constant Folding +-------------------------------------------------- + +mkCase2 mode scrut bndr alts_ty alts + | -- See Note [Scrutinee Constant Folding] + case alts of + [Alt DEFAULT _ _] -> isDeadBinder bndr -- see wrinkle 1 + _ -> True + , sm_case_folding mode + , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut + = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut') + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in GHC.Core.Opt.ConstantFold + + ; mkCase3 mode scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + + | otherwise + = mkCase3 mode scrut bndr alts_ty alts + where + -- We need to keep the correct association between the scrutinee and its + -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with + -- "let bndr = ... in": + -- + -- case v + 10 of y =====> case v of y' + -- 20 -> e1 10 -> let y = 20 in e1 + -- DEFAULT -> e2 DEFAULT -> let y = y' + 10 in e2 + -- + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) + tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (Alt con' bs' rhs')) } + where + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] + + re_sort :: [CoreAlt] -> [CoreAlt] + -- Sort the alternatives to re-establish + -- GHC.Core Note [Case expression invariants] + re_sort alts = sortBy cmpAlt alts + + add_default :: [CoreAlt] -> [CoreAlt] + -- See Note [Literal cases] + add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts + add_default alts = alts + +{- Note [Literal cases] +~~~~~~~~~~~~~~~~~~~~~~~ +If we have + case tagToEnum (a ># b) of + False -> e1 + True -> e2 + +then caseRules for TagToEnum will turn it into + case tagToEnum (a ># b) of + 0# -> e1 + 1# -> e2 + +Since the case is exhaustive (all cases are) we can convert it to + case tagToEnum (a ># b) of + DEFAULT -> e1 + 1# -> e2 + +This may generate slightly better code (although it should not, since +all cases are exhaustive) and/or optimise better. I'm not certain that +it's necessary, but currently we do make this change. We do it here, +NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] +in GHC.Core.Opt.ConstantFold) +-} + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase3 _mode scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) + +-- See Note [Exitification] and Note [Do not inline exit join points] in +-- GHC.Core.Opt.Exitify +-- This lives here (and not in Id) because occurrence info is only valid on +-- InIds, so it's crucial that isExitJoinId is only called on freshly +-- occ-analysed code. It's not a generic function you can call anywhere. +isExitJoinId :: Var -> Bool +isExitJoinId id + = isJoinId id + && isOneOcc (idOccInfo id) + && occ_in_lam (idOccInfo id) == IsInsideLam + +{- +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because it +happens bottom-up + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is correct, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. +-} diff --git a/compiler/GHC/Core/Opt/Stats.hs b/compiler/GHC/Core/Opt/Stats.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Stats.hs @@ -0,0 +1,330 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Opt.Stats ( + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..) + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Error + +import GHC.Utils.Outputable as Outputable + +import GHC.Data.FastString + +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Ord +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import GHC.Utils.Panic (throwGhcException, GhcException(..)) + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: Bool -- ^ -ddump-simpl-stats + -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: Int -- ^ History size of the elaborate counter + -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dump_simpl_stats + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dump_simpl_stats + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick history_size tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void# -> sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = NE.groupWith (tickToTag . fst) (Map.toList counts) + +pprTickGroup :: NonEmpty (Tick, Int) -> SDoc +pprTickGroup group@((tick1,_) :| _) + = hang (int (sum (fmap snd group)) <+> pprTickType tick1) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortOn (Down . snd) (NE.toList group)]) + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = pprTickType tick <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +pprTickType :: Tick -> SDoc +pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally" +pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally" +pprTickType (UnfoldingDone _) = text "UnfoldingDone" +pprTickType (RuleFired _) = text "RuleFired" +pprTickType LetFloatFromLet = text "LetFloatFromLet" +pprTickType (EtaExpansion _) = text "EtaExpansion" +pprTickType (EtaReduction _) = text "EtaReduction" +pprTickType (BetaReduction _) = text "BetaReduction" +pprTickType (CaseOfCase _) = text "CaseOfCase" +pprTickType (KnownBranch _) = text "KnownBranch" +pprTickType (CaseMerge _) = text "CaseMerge" +pprTickType (AltMerge _) = text "AltMerge" +pprTickType (CaseElim _) = text "CaseElim" +pprTickType (CaseIdentity _) = text "CaseIdentity" +pprTickType (FillInCaseDefault _) = text "FillInCaseDefault" +pprTickType SimplifierDone = text "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -38,6 +38,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import qualified Data.Data as Data import Data.Function import Data.List (find) @@ -376,7 +378,7 @@ -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type + -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type -- variables and required dicts -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type -- variables and provided dicts @@ -387,7 +389,7 @@ -> [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) @@ -506,6 +508,6 @@ , 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/Ppr.hs b/compiler/GHC/Core/Ppr.hs --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -315,8 +315,10 @@ ppr_expr add_par (Tick tickish expr) = sdocOption sdocSuppressTicks $ \case - True -> ppr_expr add_par expr - False -> add_par (sep [ppr tickish, pprCoreExpr expr]) + -- Only hide non-runtime relevant ticks. + True + | not (tickishIsCode tickish) -> ppr_expr add_par expr + _ -> add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => Alt a -> SDoc pprCoreAlt (Alt con args rhs) @@ -615,11 +617,6 @@ brackets (hsep (map int cs)), int size, int discount ] - -instance Outputable UnfoldingSource where - ppr InlineCompulsory = text "Compulsory" - ppr InlineStable = text "InlineStable" - ppr InlineRhs = text "" instance Outputable Unfolding where ppr NoUnfolding = text "No unfolding" diff --git a/compiler/GHC/Core/Ppr.hs-boot b/compiler/GHC/Core/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Ppr.hs-boot @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr where + +import {-# SOURCE #-} GHC.Core +import {-# SOURCE #-} GHC.Types.Var (Var) +import GHC.Utils.Outputable (OutputableBndr, Outputable) + +instance OutputableBndr b => Outputable (Expr b) + +instance OutputableBndr Var diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -19,7 +19,7 @@ mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- Class predicates - mkClassPred, isDictTy, + mkClassPred, isDictTy, typeDeterminesValue, isClassPred, isEqPredClass, isCTupleClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy, @@ -102,6 +102,10 @@ isDictTy :: Type -> Bool isDictTy = isClassPred +typeDeterminesValue :: Type -> Bool +-- See Note [Type determines value] +typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) + getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys) @@ -132,6 +136,19 @@ = funResultTy $ piResultTys (varType sel_id) arg_tys +{- Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-impicit-parameter predicates, because these +are the ones whose *type* determines their *value*. In particular, +with implicit params, the type args *don't* say what the value of the +implicit param is! See #7101. + +So we treat implicit params just like ordinary arguments for the +purposes of specialisation. Note that we still want to specialise +functions with implicit params if they have *other* dicts which are +class params; see #17930. +-} + -- --------------------- Equality predicates --------------------------------- -- | A choice of equality relation. This is separate from the type 'Role' @@ -225,7 +242,6 @@ isCTupleClass :: Class -> Bool isCTupleClass cls = isTupleTyCon (classTyCon cls) - {- ********************************************************************* * * diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs --- a/compiler/GHC/Core/Reduction.hs +++ b/compiler/GHC/Core/Reduction.hs @@ -35,14 +35,16 @@ import GHC.Core.Type 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 ) import GHC.Utils.Misc ( HasDebugCallStack, equalLength ) import GHC.Utils.Outputable -import GHC.Utils.Panic ( assertPpr, panic ) +import GHC.Utils.Panic ( assertPpr ) {- %************************************************************************ @@ -349,25 +351,25 @@ -- -- 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 @@ -375,7 +377,7 @@ 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 #-} @@ -784,11 +786,11 @@ -- 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 - -> [Role] -- list of roles, r + -> Infinite Role-- list of roles, r -> [Reduction] -- rewritten type arguments, arg_i -- each comes with the coercion used to rewrite it, -- arg_co_i :: ty_i ~ arg_i @@ -810,10 +812,10 @@ 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) - -> [Role] -- Roles at which to rewrite these ... - -> [Reduction] -- rewritten arguments, with their 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 @@ -826,10 +828,10 @@ kind_co | noFreeVarsOfType final_kind = MRefl | otherwise = MCo $ liftCoSubst Nominal lc final_kind - go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns) + 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 @@ -837,11 +839,11 @@ -- -- 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 @@ -859,7 +861,7 @@ (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys casted_args = assertPpr (equalLength arg_redns arg_cos) (ppr arg_redns $$ ppr arg_cos) - $ zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos + $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos -- In general decomposePiCos can return fewer cos than tys, -- but not here; because we're well typed, there will be enough -- binders. Note that decomposePiCos does substitutions, so even @@ -874,19 +876,3 @@ = go zapped_lc bndrs new_inner roles casted_args in ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out) - - go _ _ _ _ _ = panic - "simplifyArgsWorker wandered into deeper water than usual" - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872d. - -- That's independent of the analogous case in rewrite_args_fast - -- in GHC.Tc.Solver.Rewrite: - -- each of these causes a 2% increase on its own, so commenting them - -- both out gives a 4% decrease in T9872d. - {- - - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} diff --git a/compiler/GHC/Core/RoughMap.hs b/compiler/GHC/Core/RoughMap.hs --- a/compiler/GHC/Core/RoughMap.hs +++ b/compiler/GHC/Core/RoughMap.hs @@ -13,6 +13,9 @@ , RoughMatchLookupTc(..) , typeToRoughMatchLookupTc , roughMatchTcToLookup + , roughMatchTcs + , roughMatchTcsLookup + , instanceCantMatch -- * RoughMap , RoughMap @@ -37,11 +40,10 @@ 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 {- @@ -106,8 +108,12 @@ KnownTc Int, KnownTc Char]`. This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics]. -As soon as the the lookup key runs out, the remaining instances might match. +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 @@ 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 @@ -149,7 +156,7 @@ The potential matches is likely to be much smaller than the bag of potential unifiers due to the reasoning about rigid type variables described in Note [Matching a RoughMap]. On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify -with any instance (depending on the substituion of said rigid variable) so they can't be discounted +with any instance (depending on the substitution of said rigid variable) so they can't be discounted from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC. @@ -180,7 +187,7 @@ mightMatch [] [] = True -- A perfectly sized match might match mightMatch key [] = True -- A shorter lookup key matches everything mightMatch [] (_:_) = True -- If the lookup key is longer, then still might match - -- Note [RoughMatch and beta reduction] + -- Note [RoughMap and beta reduction] mightMatch (k:ks) (lk:lks) = = case (k,lk) of -- Standard case, matching on a specific known TyCon. @@ -222,20 +229,59 @@ -} +{- ********************************************************************* +* * + 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,55 @@ 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 + -- Expand synonyms first, as explained in Note [Rough matching in class and family instances]. + -- Failing to do so led to #22985. + | Just ty' <- coreView ty + = typeToRoughMatchLookupTc ty' + | CastTy ty' _ <- 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 +345,23 @@ 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,15 +370,21 @@ -- 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 - deriving (Functor) + | 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 + + , rm_wild :: RoughMap a } + -- Keyed by (RM_WildCard : rm_tcs) + deriving (Functor) + instance Outputable a => Outputable (RoughMap a) where ppr (RM empty known unknown) = vcat [text "RM" @@ -315,7 +403,7 @@ -- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists -- we find in 'rm_empty', which would otherwise be necessary due to '++' if we --- returned a list. We use a list for unifiers becuase the tail is computed lazily and +-- returned a list. We use a list for unifiers because the tail is computed lazily and -- we often only care about the first couple of potential unifiers. Constructing a -- bag forces the tail which performs much too much work. -- @@ -323,28 +411,37 @@ -- 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 +449,7 @@ 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 +457,19 @@ 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 +477,7 @@ 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 +498,13 @@ 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 +520,7 @@ -- 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 +541,7 @@ 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/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -8,49 +8,60 @@ -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( - -- ** Constructing + -- ** Looking up rules + lookupRule, + + -- ** RuleBase, RuleEnv + RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, + updExternalPackageRules, addLocalRules, updLocalRules, emptyRuleBase, mkRuleBase, extendRuleBaseList, - pprRuleBase, extendRuleEnv, + pprRuleBase, -- ** Checking rule applications ruleCheckProgram, -- ** Manipulating 'RuleInfo' rules extendRuleInfo, addRuleInfo, - addIdSpecialisations, + addIdSpecialisations, addRulesToId, + -- ** RuleBase and RuleEnv + -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames, initRuleOpts + -- * Making rules + mkRule, mkSpecRule, roughTopNames + ) where import GHC.Prelude -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) -import GHC.Driver.Flags - -import GHC.Unit.Types ( primUnitId, bignumUnitId ) import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env +import GHC.Unit.Module.ModGuts( ModGuts(..) ) +import GHC.Unit.Module.Deps( Dependencies(..) ) +import GHC.Driver.Session( DynFlags ) +import GHC.Driver.Ppr( showSDoc ) + import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) + , rulesFreeVarsDSet, exprsOrphNames ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type - ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy, getTyVar_maybe ) + ( Type, extendTvSubst, extendCvSubst + , substTy, getTyVar_maybe ) +import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -63,6 +74,7 @@ import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.Name.Occurrence( occNameFS ) import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -72,7 +84,6 @@ import GHC.Data.Bag import GHC.Utils.Misc as Utils -import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) @@ -130,7 +141,7 @@ * At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we - generate a RuleBase for (c) by combing rules from all the modules + generate a RuleBase for (c) by combining rules from all the modules "below" us. That's why we can't just select the home-package RuleBase from HscEnv. @@ -147,7 +158,7 @@ In a single simplifier run new rules can be added into the EPS so it matters to keep an up-to-date view of which rules have been loaded. For examples of - where this went wrong and caused cryptic performance regressions seee + where this went wrong and caused cryptic performance regressions see T19790 and !6735. @@ -157,33 +168,18 @@ * * ************************************************************************ -A @CoreRule@ holds details of one rule for an @Id@, which +A CoreRule holds details of one rule for an Id, which includes its specialisations. -For example, if a rule for @f@ contains the mapping: -\begin{verbatim} - forall a b d. [Type (List a), Type b, Var d] ===> f' a b -\end{verbatim} +For example, if a rule for f is + RULE "f" forall @a @b d. f @(List a) @b d = f' a b + then when we find an application of f to matching types, we simply replace it by the matching RHS: -\begin{verbatim} f (List Int) Bool dict ===> f' Int Bool -\end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the Rule contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a - -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) - -where pi' :: Lift Int# is the specialised version of pi. -} mkRule :: Module -> Bool -> Bool -> RuleName -> Activation @@ -191,18 +187,13 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs - = Rule { ru_name = name - , ru_act = act - , ru_fn = fn - , ru_bndrs = bndrs - , ru_args = args - , ru_rhs = occurAnalyseExpr rhs - -- See Note [OccInfo in unfoldings and rules] - , ru_rough = roughTopNames args - , ru_origin = this_mod - , ru_orphan = orph - , ru_auto = is_auto - , ru_local = is_local } + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } where -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables @@ -217,6 +208,40 @@ orph = chooseOrphanAnchor local_lhs_names -------------- +mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc + -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- Make a specialisation rule, for Specialise or SpecConstr +mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs + = case isJoinId_maybe fn of + Just join_arity -> etaExpandToJoinPointRule join_arity rule + Nothing -> rule + where + rule = mkRule this_mod is_auto is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + bndrs args rhs + + is_local = isLocalId fn + rule_name = mkSpecRuleName dflags herald fn args + +mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString +mkSpecRuleName dflags herald fn args + = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + -- This name ends up in interface files, so use occNameFS. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + <+> hsep (mapMaybe ppr_call_key_ty args) + where + ppr_call_key_ty :: CoreExpr -> Maybe SDoc + ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of + Just {} -> Just (text "@_") + Nothing -> Just $ char '@' <> pprParendType ty + ppr_call_key_ty _ = Nothing + + +-------------- roughTopNames :: [CoreExpr] -> [Maybe Name] -- ^ Find the \"top\" free names of several expressions. -- Such names are either: @@ -316,16 +341,118 @@ = setIdSpecialisation id $ extendRuleInfo (idSpecialisation id) rules +addRulesToId :: RuleBase -> Id -> Id +-- Add rules in the RuleBase to the rules in the Id +addRulesToId rule_base bndr + | Just rules <- lookupNameEnv rule_base (idName bndr) + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + -- | Gather all the rules for locally bound identifiers from the supplied bindings rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +{- +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +-- See Note [Orphans] in GHC.Core +data RuleEnv + = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module + , re_home_rules :: !RuleBase -- Rule from the home package + -- (excl this module) + , re_eps_rules :: !RuleBase -- Rules from other packages + -- see Note [External package rules] + , re_visible_orphs :: !ModuleSet + } + +mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv +mkRuleEnv (ModGuts { mg_module = this_mod + , mg_deps = deps + , mg_rules = local_rules }) + eps_rules hpt_rules + = RuleEnv { re_local_rules = mkRuleBase local_rules + , re_home_rules = hpt_rules + , re_eps_rules = eps_rules + , re_visible_orphs = mkModuleSet vis_orphs } + where + vis_orphs = this_mod : dep_orphs deps + +updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv +-- Completely over-ride the external rules in RuleEnv +updExternalPackageRules rule_env eps_rules + = rule_env { re_eps_rules = eps_rules } + +updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Completely over-ride the local rules in RuleEnv +updLocalRules rule_env local_rules + = rule_env { re_local_rules = mkRuleBase local_rules } + +addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Add new local rules +addLocalRules rule_env rules + = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv + , re_home_rules = emptyNameEnv + , re_eps_rules = emptyNameEnv + , re_visible_orphs = emptyModuleSet } + getRules :: RuleEnv -> Id -> [CoreRule] +-- Given a RuleEnv and an Id, find the visible rules for that Id -- See Note [Where rules are found] -getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn - = idCoreRules fn ++ concatMap imp_rules rule_base +getRules (RuleEnv { re_local_rules = local_rules + , re_home_rules = home_rules + , re_eps_rules = eps_rules + , re_visible_orphs = orphs }) fn + + | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers + = [] -- and wrappers, which never have any rules + + | otherwise + = idCoreRules fn ++ + get local_rules ++ + find_visible home_rules ++ + find_visible eps_rules + where - imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` []) + fn_name = idName fn + find_visible rb = filter (ruleIsVisible orphs) (get rb) + get rb = lookupNameEnv rb fn_name `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True @@ -351,37 +478,28 @@ in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase - -************************************************************************ -* * - RuleBase -* * -************************************************************************ --} - --- RuleBase itself is defined in GHC.Core, along with CoreRule - -emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv + Note [External package rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [Overall plumbing for rules], it is explained that the final +RuleBase which we must consider is combined from 4 different sources. -mkRuleBase :: [CoreRule] -> RuleBase -mkRuleBase rules = extendRuleBaseList emptyRuleBase rules +During simplifier runs, the fourth source of rules is constantly being updated +as new interfaces are loaded into the EPS. Therefore just before we check to see +if any rules match we get the EPS RuleBase and combine it with the existing RuleBase +and then perform exactly 1 lookup into the new map. -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl' extendRuleBase rule_base new_guys +It is more efficient to avoid combining the environments and store the uncombined +environments as we can instead perform 1 lookup into each environment and then combine +the results. -extendRuleBase :: RuleBase -> CoreRule -> RuleBase -extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule +Essentially we use the identity: -extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv -extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs) +> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) +> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 -pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = pprUFM rules $ \rss -> - vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- rss ] +The latter being more efficient as we don't construct an intermediate +map. +-} {- ************************************************************************ @@ -404,7 +522,7 @@ -- See Note [Extra args in the target] -- See comments on matchRule -lookupRule opts rule_env@(in_scope,_) is_active fn args rules +lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ case go [] rules of [] -> Nothing @@ -456,31 +574,42 @@ (fn,args) = target isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool --- This tests if one rule is more specific than another --- We take the view that a BuiltinRule is less specific than --- anything else, because we want user-define rules to "win" --- In particular, class ops have a built-in rule, but we --- any user-specific rules to win --- eg (#4397) --- truncate :: (RealFrac a, Integral b) => a -> b --- {-# RULES "truncate/Double->Int" truncate = double2Int #-} --- double2Int :: Double -> Int --- We want the specific RULE to beat the built-in class-op rule +-- The call (rule1 `isMoreSpecific` rule2) +-- sees if rule2 can be instantiated to look like rule1 +-- See Note [isMoreSpecific] isMoreSpecific _ (BuiltinRule {}) _ = False isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 , ru_name = rule_name2, ru_rhs = rhs2 }) - = isJust (matchN (full_in_scope, id_unfolding_fun) + = isJust (matchN in_scope_env rule_name2 bndrs2 args2 args1 rhs2) where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates full_in_scope = in_scope `extendInScopeSetList` bndrs1 + in_scope_env = ISE full_in_scope noUnfoldingFun + -- noUnfoldingFun: don't expand in templates noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{- Note [Extra args in the target] +{- Note [isMoreSpecific] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call (rule1 `isMoreSpecific` rule2) +sees if rule2 can be instantiated to look like rule1. + +Wrinkle: + +* We take the view that a BuiltinRule is less specific than + anything else, because we want user-defined rules to "win" + In particular, class ops have a built-in rule, but we + prefer any user-specific rules to win: + eg (#4397) + truncate :: (RealFrac a, Integral b) => a -> b + {-# RULES "truncate/Double->Int" truncate = double2Int #-} + double2Int :: Double -> Int + We want the specific RULE to beat the built-in class-op rule + +Note [Extra args in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)), /but/ the rule firing has only consumed as many of the input args @@ -528,11 +657,14 @@ -- [f,map g x] -- tpl_args -- map (f.g) x) -- rhs -- --- Then the call: matchRule the_rule [e1,map e2 e3] +-- Then the expression +-- map e1 (map e2 e3) e4 +-- results in a call to +-- matchRule the_rule [e1,map e2 e3,e4] -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- --- Any 'surplus' arguments in the input are simply put on the end --- of the output. +-- NB: The 'surplus' argument e4 in the input is simply dropped. +-- See Note [Extra args in the target] matchRule opts rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) @@ -549,18 +681,6 @@ | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs --- | Initialize RuleOpts from DynFlags -initRuleOpts :: DynFlags -> RuleOpts -initRuleOpts dflags = RuleOpts - { roPlatform = targetPlatform dflags - , roNumConstantFolding = gopt Opt_NumConstantFolding dflags - , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags - -- disable bignum rules in ghc-prim and ghc-bignum itself - , roBignumRules = homeUnitId_ dflags /= primUnitId - && homeUnitId_ dflags /= bignumUnitId - } - - --------------------------------------- matchN :: InScopeEnv -> RuleName -> [Var] -> [CoreExpr] @@ -576,10 +696,10 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs +matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) - (mkEmptyTCvSubst in_scope) $ + (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] @@ -594,7 +714,7 @@ , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } - lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) -- Need to return a RuleSubst solely for the benefit of mk_fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) @@ -629,7 +749,28 @@ , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] +---------------------- +match_exprs :: RuleMatchEnv -> RuleSubst + -> [CoreExpr] -- Templates + -> [CoreExpr] -- Targets + -> Maybe RuleSubst +-- If the targets are longer than templates, succeed, simply ignoring +-- the leftover targets. This matters in the call in matchN. +-- +-- Precondition: corresponding elements of es1 and es2 have the same +-- type, assuming earlier elements match. +-- Example: f :: forall v. v -> blah +-- match_exprs [Type a, y::a] [Type Int, 3] +-- Then, after matching Type a against Type Int, +-- the type of (y::a) matches that of (3::Int) +match_exprs _ subst [] _ + = Just subst +match_exprs renv subst (e1:es1) (e2:es2) + = do { subst' <- match renv subst e1 e2 MRefl + ; match_exprs renv subst' es1 es2 } +match_exprs _ _ _ _ = Nothing + {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be the case that the binder in a rule is not actually @@ -740,7 +881,7 @@ -} rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) +rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv) -- * The domain of the TvSubstEnv and IdSubstEnv are the template -- variables passed into the match. @@ -762,28 +903,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = [] } ----------------------- -match_exprs :: RuleMatchEnv -> RuleSubst - -> [CoreExpr] -- Templates - -> [CoreExpr] -- Targets - -> Maybe RuleSubst --- If the targets are longer than templates, succeed, simply ignoring --- the leftover targets. This matters in the call in matchN. --- --- Precondition: corresponding elements of es1 and es2 have the same --- type, assumuing earlier elements match --- Example: f :: forall v. v -> blah --- match_exprs [Type a, y::a] [Type Int, 3] --- Then, after matching Type a against Type Int, --- the type of (y::a) matches that of (3::Int) -match_exprs _ subst [] _ - = Just subst -match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl - ; match_exprs renv subst' es1 es2 } -match_exprs _ _ _ _ = Nothing - {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As far as possible we don't want casts in the target to get in the way of @@ -950,7 +1070,7 @@ -- Note the match on MRefl! We fail if there is a cast in the target -- (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match' --- we agressively ensure that if MCo is reflective, it really is MRefl. +-- we aggressively ensure that if MCo is reflective, it really is MRefl. match renv subst (App f1 a1) (App f2 a2) MRefl = do { subst' <- match renv subst f1 f2 MRefl ; match renv subst' a1 a2 MRefl } @@ -1129,7 +1249,7 @@ and we really want to spot that the co/sym-co cancels out. Hence * We keep an invariant that the MCoercion is always MRefl - if the MCoercion is reflextve + if the MCoercion is reflexive * We maintain this invariant via the call to checkReflexiveMCo in the Cast case of 'match'. -} @@ -1242,7 +1362,9 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2 - | any (inRnEnvR rn_env) (exprFreeVarsList e2) + -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs + -- if the right side of the env is empty. + | anyInRnEnvR rn_env (exprFreeVars e2) = Nothing -- Skolem-escape failure -- e.g. match forall a. (\x-> a x) against (\y. y y) @@ -1553,7 +1675,7 @@ | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (rc_rules env fn) - match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules @@ -1573,7 +1695,7 @@ = text "Rule" <+> doubleQuotes (ftext name) rule_info opts rule - | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) + | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env)) noBlackList fn args rough_args rule = text "matches (which is very peculiar!)" diff --git a/compiler/GHC/Core/Rules/Config.hs b/compiler/GHC/Core/Rules/Config.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Rules/Config.hs @@ -0,0 +1,13 @@ +module GHC.Core.Rules.Config where + +import GHC.Prelude +import GHC.Platform + +-- | Rule options +data RuleOpts = RuleOpts + { roPlatform :: !Platform -- ^ Target platform + , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding + , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled + , roBignumRules :: !Bool -- ^ Enable rules for bignums + } + diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -27,7 +27,7 @@ import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make -import GHC.Core.Make ( FloatBind(..) ) +import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Types.Literal import GHC.Types.Id @@ -36,7 +36,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.DataCon -import GHC.Types.Demand( etaConvertDmdSig ) +import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) import GHC.Types.Tickish import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList @@ -91,14 +91,15 @@ data SimpleOpts = SimpleOpts { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , so_eta_red :: !Bool -- ^ Eta reduction on? } -- | Default options for the Simple optimiser. defaultSimpleOpts :: SimpleOpts defaultSimpleOpts = SimpleOpts { so_uf_opts = defaultUnfoldingOpts - , so_co_opts = OptCoercionOpts - { optCoercionEnabled = False } + , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } + , so_eta_red = False } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -181,13 +182,10 @@ type SimpleClo = (SimpleOptEnv, InExpr) data SimpleOptEnv - = SOE { soe_co_opt_opts :: !OptCoercionOpts - -- ^ Options for the coercion optimiser - - , soe_uf_opts :: !UnfoldingOpts - -- ^ Unfolding options + = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts + -- ^ Simplifier options - , soe_inl :: IdEnv SimpleClo + , soe_inl :: IdEnv SimpleClo -- ^ Deals with preInlineUnconditionally; things -- that occur exactly once and are inlined -- without having first been simplified @@ -207,24 +205,22 @@ <+> text "}" emptyEnv :: SimpleOpts -> SimpleOptEnv -emptyEnv opts = SOE - { soe_inl = emptyVarEnv - , soe_subst = emptySubst - , soe_rec_ids = emptyUnVarSet - , soe_co_opt_opts = so_co_opts opts - , soe_uf_opts = so_uf_opts opts - } +emptyEnv opts = SOE { soe_inl = emptyVarEnv + , soe_subst = emptySubst + , soe_rec_ids = emptyUnVarSet + , soe_opts = opts } soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst }) - = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst } -soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv --- Take in-scope set from env1, and the rest from env2 -soeSetInScope (SOE { soe_subst = subst1 }) - env2@(SOE { soe_subst = subst2 }) - = env2 { soe_subst = setInScope subst2 (substInScope subst1) } +soeInScope :: SimpleOptEnv -> InScopeSet +soeInScope (SOE { soe_subst = subst }) = getSubstInScope subst +soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv +soeSetInScope in_scope env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 in_scope } + enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r) enterRecGroupRHSs env bndrs k @@ -233,9 +229,11 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} --------------- -simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr -simple_opt_clo env (e_env, e) - = simple_opt_expr (soeSetInScope env e_env) e +simple_opt_clo :: InScopeSet + -> SimpleClo + -> OutExpr +simple_opt_clo in_scope (e_env, e) + = simple_opt_expr (soeSetInScope in_scope e_env) e simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr @@ -243,18 +241,18 @@ where rec_ids = soe_rec_ids env subst = soe_subst env - in_scope = substInScope subst - in_scope_env = (in_scope, simpleUnfoldingFun) + in_scope = getSubstInScope subst + in_scope_env = ISE in_scope alwaysActiveUnfoldingFun --------------- go (Var v) | Just clo <- lookupVarEnv (soe_inl env) v - = simple_opt_clo env clo + = simple_opt_clo in_scope clo | otherwise = lookupIdSubst (soe_subst env) v go (App e1 e2) = simple_app env e1 [(env,e2)] - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (go_co co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) @@ -277,7 +275,7 @@ (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ zipEqual "simpleOptExpr" bs es - -- Note [Getting the map/coerce RULE to work] + -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b , [Alt DEFAULT _ rhs] <- as , isCoVarType (varType b) @@ -287,14 +285,14 @@ = go rhs | otherwise - = Case e' b' (substTy subst ty) + = Case e' b' (substTyUnchecked subst ty) (map (go_alt env') as) where e' = go e (env', b') = subst_opt_bndr env b ---------------------- - go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co + go_co co = optCoercion (so_co_opts (soe_opts env)) subst co ---------------------- go_alt env (Alt con bndrs rhs) @@ -312,8 +310,9 @@ where (env', b') = subst_opt_bndr env b go_lam env bs' e - | Just etad_e <- tryEtaReduce rec_ids bs e' = etad_e - | otherwise = mkLams bs e' + | so_eta_red (soe_opts env) + , Just etad_e <- tryEtaReduce rec_ids bs e' topSubDmd = etad_e + | otherwise = mkLams bs e' where bs = reverse bs' e' = simple_opt_expr env e @@ -333,12 +332,12 @@ simple_app env (Var v) as | Just (env', e) <- lookupVarEnv (soe_inl env) v - = simple_app (soeSetInScope env env') e as + = simple_app (soeSetInScope (soeInScope env) env') e as | let unf = idUnfolding v , isCompulsoryUnfolding (idUnfolding v) , isAlwaysActive (idInlineActivation v) - -- See Note [Unfold compulsory unfoldings in LHSs] + -- See Note [Unfold compulsory unfoldings in RULE LHSs] = simple_app (soeZapSubst env) (unfoldingTemplate unf) as | otherwise @@ -360,8 +359,19 @@ n_args = length as do_beta env (Lam b body) (a:as) - | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel - = wrapLet mb_pr $ do_beta env' body as + | -- simpl binder before looking at its type + -- See Note [Dark corner with representation polymorphism] + needsCaseBinding (idType b') (snd a) + -- This arg must not be inlined (side-effects) and cannot be let-bound, + -- due to the let-can-float invariant. So simply case-bind it here. + , let a' = simple_opt_clo (soeInScope env) a + = mkDefaultCase a' b' $ do_beta env' body as + + | (env'', mb_pr) <- simple_bind_pair env' b (Just b') a NotTopLevel + = wrapLet mb_pr $ do_beta env'' body as + + where (env', b') = subst_opt_bndr env b + do_beta env body as = simple_app env body as @@ -390,11 +400,19 @@ = finish_app env (simple_opt_expr env e) as finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -finish_app _ fun [] - = fun -finish_app env fun (arg:args) - = finish_app env (App fun (simple_opt_clo env arg)) args +-- See Note [Eliminate casts in function position] +finish_app env (Cast (Lam x e) co) as@(_:_) + | not (isTyVar x) && not (isCoVar x) + , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda (soeInScope env) x e co + = simple_app (soeZapSubst env) (Lam x' e') as +finish_app env fun args + = foldl mk_app fun args + where + in_scope = soeInScope env + mk_app fun arg = App fun (simple_opt_clo in_scope arg) + ---------------------- simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe OutBind) @@ -434,12 +452,12 @@ in_bndr mb_out_bndr clo@(rhs_env, in_rhs) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in - , let out_ty = substTy (soe_subst rhs_env) ty + , let out_ty = substTyUnchecked (soe_subst rhs_env) ty = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs - , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co + , let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) @@ -456,16 +474,17 @@ stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) occ = idOccInfo in_bndr + in_scope = getSubstInScope subst out_rhs | Just join_arity <- isJoinId_maybe in_bndr = simple_join_rhs join_arity | otherwise - = simple_opt_clo env clo + = simple_opt_clo in_scope clo simple_join_rhs join_arity -- See Note [Preserve join-binding arity] = mkLams join_bndrs' (simple_opt_expr env_body join_body) where - env0 = soeSetInScope env rhs_env + env0 = soeSetInScope in_scope rhs_env (join_bndrs, join_body) = collectNBinders join_arity in_rhs (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs @@ -561,6 +580,53 @@ and increase the benefit for doing so. So we unconditionally inline trivial rhss here. +Note [Eliminate casts in function position] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program: + + type R :: Type -> RuntimeRep + type family R a where { R Float = FloatRep; R Double = DoubleRep } + type F :: forall (a :: Type) -> TYPE (R a) + type family F a where { F Float = Float# ; F Double = Double# } + + type N :: forall (a :: Type) -> TYPE (R a) + newtype N a = MkN (F a) + +As MkN is a newtype, its unfolding is a lambda which wraps its argument +in a cast: + + MkN :: forall (a :: Type). F a -> N a + MkN = /\a \(x::F a). x |> co_ax + -- recall that F a :: TYPE (R a) + +This is a representation-polymorphic lambda, in which the binder has an unknown +representation (R a). We can't compile such a lambda on its own, but we can +compile instantiations, such as `MkN @Float` or `MkN @Double`. + +Our strategy to avoid running afoul of the representation-polymorphism +invariants of Note [Representation polymorphism invariants] in GHC.Core is thus: + + 1. Give the newtype a compulsory unfolding (it has no binding, as we can't + define lambdas with representation-polymorphic value binders in source Haskell). + 2. Rely on the optimiser to beta-reduce away any representation-polymorphic + value binders. + +For example, consider the application + + MkN @Float 34.0# + +After inlining MkN we'll get + + ((/\a \(x:F a). x |> co_ax) @Float) |> co 34# + +where co :: (F Float -> N Float) ~ (Float# ~ N Float) + +But to actually beta-reduce that lambda, we need to push the 'co' +inside the `\x` with pushCoecionIntoLambda. Hence the extra +equation for Cast-of-Lam in finish_app. + +This is regrettably delicate. + Note [Preserve join-binding arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful /not/ to eta-reduce the RHS of a join point, lest we lose @@ -646,7 +712,7 @@ Subst in_scope id_subst tv_subst cv_subst = subst id1 = uniqAway in_scope old_id - id2 = updateIdTypeAndMult (substTy subst) id1 + id2 = updateIdTypeAndMult (substTyUnchecked subst) id1 new_id = zapFragileIdInfo id2 -- Zaps rules, unfolding, and fragile OccInfo -- The unfolding and rules will get added back later, by add_info @@ -671,7 +737,7 @@ | otherwise = lazySetIdInfo new_bndr new_info where subst = soe_subst env - uf_opts = soe_uf_opts env + uf_opts = so_uf_opts (soe_opts env) old_info = idInfo old_bndr -- Add back in the rules and unfolding which were @@ -690,16 +756,11 @@ | otherwise = unfolding_from_rhs - unfolding_from_rhs = mkUnfolding uf_opts InlineRhs + unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc (isTopLevel top_level) False -- may be bottom or not new_rhs Nothing -simpleUnfoldingFun :: IdUnfoldingFun -simpleUnfoldingFun id - | isAlwaysActive (idInlineActivation id) = idUnfolding id - | otherwise = noUnfolding - wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr wrapLet Nothing body = body wrapLet (Just (b,r)) body = Let (NonRec b r) body @@ -724,8 +785,8 @@ When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 -Note [Unfold compulsory unfoldings in LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Unfold compulsory unfoldings in RULE LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the user writes `RULES map coerce = coerce` as a rule, the rule will only ever match if simpleOptExpr replaces coerce by its unfolding on the LHS, because that is the core that the rule matching engine @@ -1006,7 +1067,7 @@ case $WMkT (I# 3) |> sym axT of I# y -> ... we clearly want to simplify this. If $WMkT did not have a compulsory unfolding, we would end up with - let a = I#3 in case a of I# y -> ... + let a = I# 3 in case a of I# y -> ... because in general, we do this on-the-fly beta-reduction (\x. e) blah --> let x = blah in e and then float the let. (Substitution would risk duplicating 'blah'.) @@ -1118,7 +1179,7 @@ exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr +exprIsConApp_maybe ise@(ISE in_scope id_unf) expr = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) where go :: Either InScopeSet Subst @@ -1140,6 +1201,30 @@ MRefl -> go subst floats expr (CC args' co2) go subst floats (App fun arg) (CC args co) + | let arg_type = exprType arg + , not (isTypeArg arg) && needsCaseBinding arg_type arg + -- An unlifted argument that’s not ok for speculation must not simply be + -- put into the args, as these are going to be substituted into the case + -- alternatives, and possibly lost on the way. + -- + -- Instead, we need need to + -- make sure they are evaluated right here (using a case float), and + -- the case binder can then be substituted into the case alternaties. + -- + -- Example: + -- Simplifying case Mk# exp of Mk# a → rhs + -- will use exprIsConApp_maybe (Mk# exp) + -- + -- Bad: returning (Mk#, [exp]) with no floats + -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec + -- 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 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) + | otherwise = go subst floats fun (CC (subst_expr subst arg : args) co) go subst floats (Lam bndr body) (CC (arg:args) co) @@ -1168,7 +1253,7 @@ go subst'' (float:floats) expr cont go (Right sub) floats (Var v) cont - = go (Left (substInScope sub)) + = go (Left (getSubstInScope sub)) floats (lookupIdSubst sub v) cont @@ -1214,7 +1299,7 @@ | (fun `hasKey` unpackCStringIdKey) || (fun `hasKey` unpackCStringUtf8IdKey) , [arg] <- args - , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + , Just (LitString str) <- exprIsLiteral_maybe ise arg = succeedWith in_scope floats $ dealWithStringLiteral fun str co where @@ -1238,6 +1323,13 @@ ---------------------------- -- Operations on the (Either InScopeSet GHC.Core.Subst) -- The Left case is wildly dominant + + subst_in_scope (Left in_scope) = in_scope + subst_in_scope (Right s) = getSubstInScope s + + subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v) + subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v) + subst_co (Left {}) co = co subst_co (Right s) co = GHC.Core.Subst.substCo s co @@ -1303,7 +1395,7 @@ -- Nevertheless we do need to look through unfoldings for -- string literals, which are vigorously hoisted to top level -- and not subsequently inlined -exprIsLiteral_maybe env@(_, id_unf) e +exprIsLiteral_maybe env@(ISE _ id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? @@ -1333,14 +1425,14 @@ = Just (x, e, []) -- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) +exprIsLambda_maybe ise (Tick t e) | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + , Just (x, e, ts) <- exprIsLambda_maybe ise e = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e +exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) @@ -1351,7 +1443,7 @@ res -- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e +exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e | (Var f, as, ts) <- collectArgsTicks tickishFloatable e , idArity f > count isValArg as -- Make sure there is hope to get a lambda @@ -1359,7 +1451,7 @@ -- Optimize, for beta-reduction , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as) -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , Just (x', e'', ts') <- exprIsLambda_maybe ise e' , let res = Just (x', e'', ts++ts') = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) res diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst ( -- * Main data types Subst(..), -- Implementation exported for supercompiler's Renaming.hs only @@ -15,18 +13,20 @@ -- ** Substituting into expressions and related types deShadowBinds, substRuleInfo, substRulesForImportedIds, - substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - lookupIdSubst, substIdType, substIdOcc, + lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + extendIdSubstWithClone, + extendSubst, extendSubstList, extendSubstWithVar, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, - isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, - delBndr, delBndrs, + isInScope, setInScope, getSubstInScope, + extendTvSubst, extendCvSubst, + delBndr, delBndrs, zapSubst, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, @@ -40,14 +40,11 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils -import qualified GHC.Core.Type as Type -import qualified GHC.Core.Coercion as Coercion -- We are defining local versions -import GHC.Core.Type hiding - ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Coercion + ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr ) import GHC.Types.Var.Set import GHC.Types.Var.Env as InScopeSet @@ -66,10 +63,9 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) - - {- ************************************************************************ * * @@ -78,37 +74,12 @@ ************************************************************************ -} --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' --- substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. Note [The substitution invariant] in "GHC.Core.TyCo.Subst" --- --- 2. Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -data Subst - = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ - -- applying the substitution - IdSubstEnv -- Substitution from NcIds to CoreExprs - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions - - -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] - -- This is what lets us deal with name capture properly - -- It's a hard invariant to check... - -- - -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with - -- Types.TvSubstEnv - -- - -- INVARIANT 3: See Note [Extending the Subst] - {- -Note [Extending the Subst] +Note [Extending the IdSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a core Subst, which binds Ids as well, we make a different choice for Ids -than we do for TyVars. +We make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst. +For TyVars, see Note [Extending the TvSubstEnv and CvSubstEnv] in GHC.Core.TyCo.Subst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -158,31 +129,13 @@ easy to spot -} --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions - ---------------------------- -isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env cv_env) - = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv - -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs - --- | Find the in-scope set: see "GHC.Core.TyCo.Subst" Note [The substitution invariant] -substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _ _) = in_scope - --- | Remove all substitutions for 'Id's and 'Var's that might have been built up --- while preserving the in-scope set -zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv +-- We keep GHC.Core.Subst separate from GHC.Core.TyCo.Subst to avoid creating +-- circular dependencies. Functions in this file that don't depend on +-- the definition of CoreExpr can be moved to GHC.Core.TyCo.Subst, as long +-- as it does not require importing too many additional hs-boot files and +-- cause a significant drop in performance. -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is -- such that TyCoSubst Note [The substitution invariant] @@ -193,38 +146,20 @@ = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $ Subst in_scope (extendVarEnv ids v r) tvs cvs +extendIdSubstWithClone :: Subst -> Id -> Id -> Subst +extendIdSubstWithClone (Subst in_scope ids tvs cvs) v v' + = assertPpr (isNonCoVarId v) (ppr v $$ ppr v') $ + Subst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv ids v (varToCoreExpr v')) tvs cvs + where + new_in_scope = tyCoVarsOfType (varType v') `extendVarSet` v' + -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs = assert (all (isNonCoVarId . fst) prs) $ Subst in_scope (extendVarEnvList ids prs) tvs cvs --- | Add a substitution for a 'TyVar' to the 'Subst' --- The 'TyVar' *must* be a real TyVar, and not a CoVar --- You must ensure that the in-scope set is such that --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] holds --- after extending the substitution like this. -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) tv ty - = assert (isTyVar tv) $ - Subst in_scope ids (extendVarEnv tvs tv ty) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList subst vrs - = foldl' extend subst vrs - where - extend subst (v, r) = extendTvSubst subst v r - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': --- you must ensure that the in-scope set satisfies --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] --- after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r - = assert (isCoVar v) $ - Subst in_scope ids tvs (extendVarEnv cvs v r) - -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' @@ -249,16 +184,24 @@ extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' +-- The Id should not be a CoVar lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr lookupIdSubst (Subst in_scope ids _ _) v - | not (isLocalId v) = Var v + | assertPpr (isId v && not (isCoVar v)) (ppr v) + not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] + -- Vital! See Note [Extending the IdSubstEnv] -- If v isn't in the InScopeSet, we panic, because - -- it's a bad bug and we reallly want to know + -- it's a bad bug and we really want to know | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) +lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr +-- Just look up in the substitution; do not check the in-scope set +lookupIdSubst_maybe (Subst _ ids _ _) v + = assertPpr (isId v && not (isCoVar v)) (ppr v) $ + lookupVarEnv ids v + delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) @@ -281,42 +224,7 @@ (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ -isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope --- | Add the 'Var' to the in-scope set -extendSubstInScope :: Subst -> Var -> Subst -extendSubstInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `InScopeSet.extendInScopeSet` v) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeList :: Subst -> [Var] -> Subst -extendSubstInScopeList (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeSet :: Subst -> VarSet -> Subst -extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) - ids tvs cvs - -setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs - --- Pretty printing, for debugging only - -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = text " in_scope_doc - $$ text " IdSubst =" <+> ppr ids - $$ text " TvSubst =" <+> ppr tvs - $$ text " CvSubst =" <+> ppr cvs - <> char '>' - where - in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) - {- ************************************************************************ * * @@ -339,14 +247,14 @@ -- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -- -- Do *not* attempt to short-cut in the case of an empty substitution! --- See Note [Extending the Subst] +-- See Note [Extending the IdSubstEnv] substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr -- HasDebugCallStack so we can track failures in lookupIdSubst substExpr subst expr = go expr where go (Var v) = lookupIdSubst subst v - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) @@ -366,7 +274,7 @@ where (subst', bind') = substBind subst bind - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts) where (subst', bndr') = substBndr subst bndr @@ -442,15 +350,18 @@ | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right -substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs +substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var) +substBndrs = mapAccumL substBndr +{-# INLINE substBndrs #-} -- | Substitute in a mutually recursive group of 'Id's -substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id) substRecBndrs subst bndrs = (new_subst, new_bndrs) where -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs +{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-} +{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-} substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo @@ -464,7 +375,7 @@ where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 - | otherwise = updateIdTypeAndMult (substTy subst) id1 + | otherwise = updateIdTypeAndMult (substTyUnchecked subst) id1 old_ty = idType old_id old_w = idMult old_id @@ -484,7 +395,7 @@ | otherwise = extendVarEnv env old_id (Var new_id) no_change = id1 == old_id - -- See Note [Extending the Subst] + -- See Note [Extending the IdSubstEnv] -- it's /not/ necessary to check mb_new_info and no_type_change {- @@ -494,12 +405,14 @@ -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for -- each variable in its output. It substitutes the IdInfo though. +-- Discards non-Stable unfoldings cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) cloneIdBndr subst us old_id = clone_id subst subst (old_id, uniqFromSupply us) -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final -- substitution from left to right +-- Discards non-Stable unfoldings cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) @@ -525,6 +438,7 @@ -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use +-- Discards non-Stable unfoldings clone_id :: Subst -- Substitution for the IdInfo -> Subst -> (Id, Unique) -- Substitution and Id to transform -> (Subst, Id) -- Transformed pair @@ -544,41 +458,8 @@ Types and Coercions * * ************************************************************************ - -For types and coercions we just call the corresponding functions in -Type and Coercion, but we have to repackage the substitution, from a -Subst to a TCvSubst. -} -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) -cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -substCoVarBndr :: Subst -> CoVar -> (Subst, CoVar) -substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (Subst in_scope' id_env tv_env' cv_env', cv') - --- | See 'GHC.Core.Type.substTy'. -substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty - -getTCvSubst :: Subst -> TCvSubst -getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: HasCallStack => Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getTCvSubst subst) co - {- ************************************************************************ * * @@ -592,7 +473,7 @@ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id | otherwise = - updateIdTypeAndMult (substTy subst) id + updateIdTypeAndMult (substTyUnchecked subst) id -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself @@ -602,6 +483,7 @@ ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +-- Discards unfoldings, unless they are Stable substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing @@ -632,7 +514,7 @@ args' = map (substExpr subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) - -- Retain an InlineRule! + -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding | otherwise -- But keep a stable one! @@ -705,7 +587,7 @@ = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc | otherwise , let fv_expr = lookupIdSubst subst fv - = expr_fvs fv_expr isLocalVar emptyVarSet $! acc + = exprFVs fv_expr (const True) emptyVarSet $! acc ------------------ substTickish :: Subst -> CoreTickish -> CoreTickish @@ -765,7 +647,7 @@ Second, we have to ensure that we never try to substitute a literal for an Id in a breakpoint. We ensure this by never storing an Id with -an unlifted type in a Breakpoint - see GHC.HsToCore.Coverage.mkTickish. +an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. -} diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -8,7 +8,6 @@ -} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy ( tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs ) where @@ -34,7 +33,6 @@ import GHC.Data.Maybe import GHC.Utils.Misc import Data.List (mapAccumL) --- import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Types.RepType (typePrimRep) import GHC.Utils.Panic @@ -84,7 +82,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. -- --- The actual logic is in computeCbvInfo and takes: +-- The actual logic is in tidyCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks. @@ -117,8 +115,7 @@ -- See Note [CBV Function Ids] tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id -tidyCbvInfoLocal id rhs - | otherwise = computeCbvInfo id rhs +tidyCbvInfoLocal id rhs = computeCbvInfo id rhs -- | For a binding we: -- * Look at the args @@ -135,9 +132,9 @@ -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs - | (isWorkerLike || isJoinId fun_id) && (valid_unlifted_worker val_args) - = - -- pprTrace "computeCbvInfo" + | is_wkr_like || isJust mb_join_id + , valid_unlifted_worker val_args + = -- pprTrace "computeCbvInfo" -- (text "fun" <+> ppr fun_id $$ -- text "arg_tys" <+> ppr (map idType val_args) $$ @@ -146,31 +143,48 @@ -- text "cbv_marks" <+> ppr cbv_marks $$ -- text "out_id" <+> ppr cbv_bndr $$ -- ppr rhs) - cbv_bndr + cbv_bndr + | otherwise = fun_id where - val_args = filter isId . fst $ collectBinders rhs - cbv_marks = - -- CBV marks are only set during tidy so none should be present already. - assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ - map mkMark val_args - cbv_bndr - | valid_unlifted_worker val_args - , any isMarkedCbv cbv_marks - -- seqList to avoid retaining the original rhs - = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks - | otherwise = - -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs) - asNonWorkerLikeId fun_id - -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments. - -- Doing so would require us to compute the result of unarise here in order to properly determine - -- argument positions at runtime. - -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate - -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support + mb_join_id = isJoinId_maybe fun_id + is_wkr_like = isWorkerLikeId fun_id + + val_args = filter isId lam_bndrs + -- When computing CbvMarks, we limit the arity of join points to + -- the JoinArity, because that's the arity we are going to use + -- when calling it. There may be more lambdas than that on the RHS. + lam_bndrs | Just join_arity <- mb_join_id + = fst $ collectNBinders join_arity rhs + | otherwise + = fst $ collectBinders rhs + + cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already. + assertPpr (maybe True null $ idCbvMarks_maybe fun_id) + (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ + map mkMark val_args + + cbv_bndr | any isMarkedCbv cbv_marks + = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks + -- seqList: avoid retaining the original rhs + + | otherwise + = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" + -- (ppr fun_id <+> ppr rhs) + asNonWorkerLikeId fun_id + + -- We don't set CBV marks on functions which take unboxed tuples or sums as + -- arguments. Doing so would require us to compute the result of unarise + -- here in order to properly determine argument positions at runtime. + -- + -- In practice this doesn't matter much. Most "interesting" functions will + -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed + -- sums are rarely used. But we could change this in the future and support -- unboxed sums/tuples as well. valid_unlifted_worker args = -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $ all isSingleUnarisedArg args + isSingleUnarisedArg v | isUnboxedSumType ty = False | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty) @@ -188,7 +202,6 @@ , not (isDeadEndId fun_id) = MarkedCbv | otherwise = NotMarkedCbv - isWorkerLike = isWorkerLikeId fun_id ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr @@ -339,7 +352,7 @@ new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` arityInfo old_info - `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) + `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf @@ -386,7 +399,7 @@ (a) To make printing tidy core nicer - (b) Because we tidy RULES and InlineRules, which may then propagate + (b) Because we tidy RULES and unfoldings, which may then propagate via --make into the compilation of the next module, and we want the benefit of that occurrence analysis when we use the rule or or inline the function. In particular, it's vital not to lose diff --git a/compiler/GHC/Core/TyCo/Compare.hs b/compiler/GHC/Core/TyCo/Compare.hs new file mode 100644 --- /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 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -30,6 +30,15 @@ anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + -- * Free type constructors + tyConsOfType, tyConsOfTypes, + + -- * Free vars with visible/invisible separate + visVarsOfTypes, visVarsOfType, + + -- * Occurrence-check expansion + occCheckExpand, + -- * Well-scoped free variables scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, @@ -44,19 +53,26 @@ 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 {- %************************************************************************ @@ -219,7 +235,7 @@ * * ********************************************************************* -} -{- Note [Acumulating parameter free variables] +{- Note [Accumulating parameter free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can use foldType to build an accumulating-parameter version of a free-var finder, thus: @@ -254,7 +270,7 @@ AppTy equation we don't build a thunk for (fvs env t2 acc). The optimiser does do all this, but not very robustly. It depends -critially on the basic arity-2 function not being exported, so that +critically on the basic arity-2 function not being exported, so that all its calls are visibly to three arguments. This analysis is done by the Call Arity pass. @@ -283,7 +299,7 @@ -- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of Coercions] +-- See Note [Free variables of types] tyCoVarsOfCo co = runTyCoVars (deep_co co) tyCoVarsOfMCo :: MCoercion -> TyCoVarSet @@ -575,7 +591,7 @@ 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. ) tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs @@ -617,7 +633,7 @@ = (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 @@ `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 (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 (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 @@ +{- +%************************************************************************ +%* * + 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 @@ -- * 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,274 @@ -- | 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` tyConsOfTypes 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_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + +tyConsOfTypes :: [Type] -> UniqSet TyCon +tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys + +{- ********************************************************************** +* * + 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/FVs.hs-boot b/compiler/GHC/Core/TyCo/FVs.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/TyCo/FVs.hs-boot @@ -0,0 +1,6 @@ +module GHC.Core.TyCo.FVs where + +import GHC.Prelude ( Bool ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) + +noFreeVarsOfType :: Type -> Bool diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -27,14 +27,14 @@ 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.FVs import GHC.Core.Class import GHC.Types.Var - +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Iface.Type import GHC.Types.Var.Set @@ -68,17 +68,11 @@ works just by setting the initial context precedence very high. Note that any function which pretty-prints a @Type@ first converts the @Type@ -to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. +to an @IfaceType@. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. See Note [Precedence in types] in GHC.Types.Basic. -} --------------------------------------------------------- --- When pretty-printing types, we convert to IfaceType, --- and pretty-print that. --- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr --------------------------------------------------------- - pprType, pprParendType, pprTidiedType :: Type -> SDoc pprType = pprPrecType topPrec pprParendType = pprPrecType appPrec @@ -167,18 +161,18 @@ 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 @@ -236,18 +230,15 @@ 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 (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 @@ -269,7 +260,7 @@ -- 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, @@ -282,7 +273,7 @@ -- 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, @@ -294,7 +285,7 @@ -- 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 --- a/compiler/GHC/Core/TyCo/Ppr.hs-boot +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -5,6 +5,7 @@ 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 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -30,13 +30,13 @@ 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 @@ -- * Functions over types mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, + mkFunTy, mkNakedFunTy, + 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 @@ 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 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 @@ -- 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,11 +162,15 @@ | 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. | CastTy @@ -232,9 +234,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ * 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 @@ 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). @@ -569,7 +561,7 @@ about outermost casts to uphold (EQ). Eliminating reflexive casts is done in mkCastTy. This is (EQ1) below. -Unforunately, that's not the end of the story. Consider comparing +Unfortunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> )) (c |> co) These two types have the same kind (Type), but the left type is a TyConApp while the right type is not. To handle this case, we say that the right-hand @@ -634,7 +626,7 @@ 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 @@ 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 @@ {- ********************************************************************** * * - 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 @@ mkTyCoVarTys :: [TyCoVar] -> [Type] mkTyCoVarTys = map mkTyCoVarTy -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`, - `mkInvisFunTyMany` -- Associates to the right +infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany` -mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type -mkFunTy af mult arg res = FunTy { ft_af = af - , ft_mult = mult - , ft_arg = arg - , ft_res = res } +mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind +-- See Note [Naked FunTy] in GHC.Builtin.Types +-- Always Many multiplicity; kinds have no linearity +mkNakedFunTy af arg res + = FunTy { ft_af = af, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } -mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type -mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg 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 } -mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg +mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type +mkInvisFunTy arg res + = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkFunTyMany af = mkFunTy af manyDataConTy +mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type +mkInvisFunTys args res + = foldr (mkFunTy af manyDataConTy) res args + where + af = invisArg (typeTypeOrConstraint res) --- | Special, common, case: Arrow type with mult Many -mkVisFunTyMany :: Type -> Type -> Type -mkVisFunTyMany = mkVisFunTy manyDataConTy +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 } -mkInvisFunTyMany :: Type -> Type -> Type -mkInvisFunTyMany = mkInvisFunTy manyDataConTy +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 -mkVisFunTys :: [Scaled Type] -> Type -> Type -mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys +-- | Special, common, case: Arrow type with mult Many +mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type +-- Always TypeLike, multiplicity Many +mkVisFunTyMany = mkVisFunTy manyDataConTy 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 @@ | 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 @@ | 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 @@ -- 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 @@ 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 @@ 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 @@ 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 : (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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -1720,7 +1635,7 @@ holes are easier. - Moreover, nothing is lost from the lack of let-bindings. For - dictionaries want to achieve sharing to avoid recomoputing the + dictionaries want to achieve sharing to avoid recomputing the dictionary. But coercions are entirely erased, so there's little benefit to sharing. Indeed, even if we had a let-binding, we always inline types and coercions at every use site and drop the @@ -1886,7 +1801,7 @@ -- ^ 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 @@ 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 (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 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -3,28 +3,39 @@ 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 +type RuntimeRepType = Type type Kind = Type 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 +mkNakedFunTy :: FunTyFlag -> Type -> Type -> Type -instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom + +-- To support Data instances in GHC.Core.Coercion.Axiom +instance Data Type + +-- To support instances PiTyBinder in Var +instance Data a => Data (Scaled a) + +-- 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 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -6,27 +6,25 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst ( -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, elemTCvSubst, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, + emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, + emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, + mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + getTvSubstEnv, getIdSubstEnv, + getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + isInScope, elemSubst, notElemSubst, zapSubst, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, + unionSubst, zipTyEnv, zipCoEnv, zipTvSubst, zipCvSubst, zipTCvSubst, mkTvSubstPrs, @@ -45,9 +43,9 @@ substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substTyCoBndr, - substForAllCoBndr, + substTyVar, substTyVars, substTyVarToTyVar, + substTyCoVars, + substTyCoBndr, substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, ) where @@ -55,16 +53,18 @@ 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 , coercionKind, coercionLKind, coVarKindsTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -95,28 +95,34 @@ %************************************************************************ -} --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant +-- | Type & coercion & id substitution -- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TCvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] +-- The "Subst" data type defined in this module contains substitution +-- for tyvar, covar and id. However, operations on IdSubstEnv (mapping +-- from "Id" to "CoreExpr") that require the definition of the "Expr" +-- data type are defined in GHC.Core.Subst to avoid circular module +-- dependency. +data Subst + = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from NcIds to CoreExprs + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + -- INVARIANT 1: See Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- + -- INVARIANT 2: The substitution is apply-once; + -- see Note [Substitutions apply only once] + -- + -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst" + -- and Note [Extending the TvSubstEnv and CvSubstEnv] + -- + -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] + +-- | A substitution of 'Expr's for non-coercion 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NonCoVarIds, i.e. not coercions + -- | A substitution of 'Type's for 'TyVar's -- and 'Kind's for 'KindVar's type TvSubstEnv = TyVarEnv Type @@ -139,8 +145,6 @@ (SIa) The free vars of the range of the substitution (SIb) The free vars of ty minus the domain of the substitution -The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) - * Reason for (SIa). Consider substTy [a :-> Maybe b] (forall b. b->a) we must rename the forall b, to get @@ -179,7 +183,7 @@ A TCvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. -Note [Extending the TCvSubstEnv] +Note [Extending the TvSubstEnv and CvSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #tcvsubst_invariant# for the invariants that must hold. @@ -203,128 +207,150 @@ * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty -Note [Substituting types and coercions] +Note [Substituting types, coercions, and expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types and coercions are mutually recursive, and either may have variables "belonging" to the other. Thus, every time we wish to substitute in a type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. +Likewise, expressions may contain type variables or coercion variables. +However, we use different constructors for constructing expression variables, +coercion variables, and type variables, so we carry three VarEnvs for each +variable type. Note that it would be possible to use the CoercionTy constructor +and the Type constructor to combine these environments, but that seems like a +false economy. -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with +Note that the domain of the VarEnvs must be respected, despite the fact that +TyVar, Id, and CoVar are all type synonyms of the Var type. For example, +TvSubstEnv should *never* map a CoVar (built with the Id constructor) +and the CvSubstEnv should *never* map a TyVar. Furthermore, the range +of the TvSubstEnv should *never* include a type headed with CoercionTy. -} +emptyIdSubstEnv :: IdSubstEnv +emptyIdSubstEnv = emptyVarEnv + emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv emptyCvSubstEnv :: CvSubstEnv emptyCvSubstEnv = emptyVarEnv -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - -- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 +-- like in function composition. This function leaves IdSubstEnv untouched +-- because IdSubstEnv is not used during substitution for types. +composeTCvSubst :: Subst -> Subst -> Subst +composeTCvSubst subst1@(Subst is1 ids1 tenv1 cenv1) (Subst is2 _ tenv2 cenv2) + = Subst is3 ids1 tenv3 cenv3 where is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy extended_subst1) tenv2 + cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo extended_subst1) cenv2 -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + -- Make sure the in-scope set in the first substitution is wide enough to + -- cover the free variables in the range of the second substitution before + -- applying it (#22235). + extended_subst1 = subst1 `setInScope` is3 -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TCvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- | Checks whether the tyvar and covar environments are empty. +-- This function should be used over 'isEmptySubst' when substituting +-- for types, because types currently do not contain expressions; we can +-- safely disregard the expression environment when deciding whether +-- to skip a substitution. Using 'isEmptyTCvSubst' gives us a non-trivial +-- performance boost (up to 70% less allocation for T18223) +isEmptyTCvSubst :: Subst -> Bool +isEmptyTCvSubst (Subst _ _ tv_env cv_env) + = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs + +mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst +mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> Subst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv +mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst -- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv +mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env +getIdSubstEnv :: Subst -> IdSubstEnv +getIdSubstEnv (Subst _ ids _ _) = ids -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env +getTvSubstEnv :: Subst -> TvSubstEnv +getTvSubstEnv (Subst _ _ tenv _) = tenv -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope +getCvSubstEnv :: Subst -> CvSubstEnv +getCvSubstEnv (Subst _ _ _ cenv) = cenv +-- | Find the in-scope set: see Note [The substitution invariant] +getSubstInScope :: Subst -> InScopeSet +getSubstInScope (Subst in_scope _ _ _) = in_scope + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + -- | Returns the free variables of the types in the range of a substitution as -- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs +getSubstRangeTyCoFVs :: Subst -> VarSet +getSubstRangeTyCoFVs (Subst _ _ tenv cenv) + = tenvFVs `unionVarSet` cenvFVs where tenvFVs = shallowTyCoVarsOfTyVarEnv tenv cenvFVs = shallowTyCoVarsOfCoVarEnv cenv -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -elemTCvSubst :: Var -> TCvSubst -> Bool -elemTCvSubst v (TCvSubst _ tenv cenv) +elemSubst :: Var -> Subst -> Bool +elemSubst v (Subst _ ids tenv cenv) | isTyVar v = v `elemVarEnv` tenv - | otherwise + | isCoVar v = v `elemVarEnv` cenv - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v = not . elemTCvSubst v - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + | otherwise + = v `elemVarEnv` ids -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv +notElemSubst :: Var -> Subst -> Bool +notElemSubst v = not . elemSubst v -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv +-- | Remove all substitutions that might have been built up +-- while preserving the in-scope set +-- originally called zapSubstEnv +zapSubst :: Subst -> Subst +zapSubst (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv +-- | Add the 'Var' to the in-scope set +extendSubstInScope :: Subst -> Var -> Subst +extendSubstInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + ids tvs cvs -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeList :: Subst -> [Var] -> Subst +extendSubstInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + ids tvs cvs -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeSet :: Subst -> VarSet -> Subst +extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) + ids tvs cvs -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst extendTCvSubst subst v ty | isTyVar v = extendTvSubst subst v ty @@ -333,102 +359,119 @@ | otherwise = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst extendTCvSubstWithClone subst tcv | isTyVar tcv = extendTvSubstWithClone subst tcv | otherwise = extendCvSubstWithClone subst tcv -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = assert (isTyVar tv) $ + Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty = assert (isTyVar v ) extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _ = subst -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) +extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone +-- Does not look in the kind of the new variable; +-- those variables should be in scope already +extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv' + = Subst (extendInScopeSet in_scope tv') + idenv (extendVarEnv tenv tv (mkTyVarTy tv')) cenv - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = assert (isCoVar v) $ + Subst in_scope ids tvs (extendVarEnv cvs v r) -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) +extendCvSubstWithClone :: Subst -> CoVar -> CoVar -> Subst +extendCvSubstWithClone (Subst in_scope ids tenv cenv) cv cv' + = Subst (extendInScopeSetSet in_scope new_in_scope) + ids tenv (extendVarEnv cenv cv (mkCoVarCo cv')) where new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst -- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) +extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty + = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + ids (extendVarEnv tenv tv ty) cenv -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst extendTCvSubstList subst tvs tys = foldl2 extendTCvSubst subst tvs tys -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +unionSubst :: Subst -> Subst -> Subst -- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = assert (tenv1 `disjointVarEnv` tenv2 +unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2) + = assert (ids1 `disjointVarEnv` ids2 + && tenv1 `disjointVarEnv` tenv2 && cenv1 `disjointVarEnv` cenv2 ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated + Subst (in_scope1 `unionInScope` in_scope2) + (ids1 `plusVarEnv` ids2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +-- | Generates the in-scope set for the 'Subst' from the types in the incoming +-- environment. No CoVars or Ids, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> Subst zipTvSubst tvs tys = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- | Generates the in-scope set for the 'Subst' from the types in the incoming -- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv where cenv = zipCoEnv cvs cos -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst zipTCvSubst tcvs tys = zip_tcvsubst tcvs tys $ - mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + mkEmptySubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> Subst -> Subst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) zip_tcvsubst [] [] subst = subst -- empty case zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) + (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs [] = emptyTCvSubst +-- incoming environment. No CoVars, please! The InScopeSet is just a thunk +-- so with a bit of luck it'll never be evaluated +mkTvSubstPrs :: [(TyVar, Type)] -> Subst +mkTvSubstPrs [] = emptySubst mkTvSubstPrs prs = assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $ mkTvSubst in_scope tenv @@ -438,6 +481,7 @@ and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] +-- | The InScopeSet is just a thunk so with a bit of luck it'll never be evaluated zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn @@ -467,13 +511,18 @@ | otherwise = mkVarEnv (zipEqual "zipCoEnv" cvs cos) -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] +-- Pretty printing, for debugging only +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text " in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + {- %************************************************************************ %* * @@ -614,16 +663,17 @@ -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope :: Subst -> Type -> Type substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty -- | When calling `substTy` it should be the case that the in-scope set in -- the substitution is a superset of the free vars of the range of the -- substitution. -- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = +-- TODO: take into account ids and rename as isValidSubst +isValidTCvSubst :: Subst -> Bool +isValidTCvSubst (Subst in_scope _ tenv cenv) = (tenvFVs `varSetInScope` in_scope) && (cenvFVs `varSetInScope` in_scope) where @@ -632,8 +682,8 @@ -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant]. -checkValidSubst :: HasDebugCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a +checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a = assertPpr (isValidTCvSubst subst) (text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ @@ -663,9 +713,9 @@ -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTy :: HasDebugCallStack => TCvSubst -> Type -> Type +substTy :: HasDebugCallStack => Subst -> Type -> Type substTy subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty @@ -674,26 +724,26 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty -substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty -substScaledTyUnchecked :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTyUnchecked :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty -- | Substitute within several 'Type's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTys :: HasDebugCallStack => TCvSubst -> [Type] -> [Type] +substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] substTys subst tys | isEmptyTCvSubst subst = tys | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -substScaledTys :: HasDebugCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type] substScaledTys subst scaled_tys | isEmptyTCvSubst subst = scaled_tys | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ @@ -704,12 +754,12 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTysUnchecked to -- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked :: Subst -> [Type] -> [Type] substTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (subst_ty subst) tys -substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type] substScaledTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (mapScaledType (subst_ty subst)) tys @@ -717,7 +767,7 @@ -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTheta :: HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType substTheta = substTys -- | Substitute within a 'ThetaType' disabling the sanity checks. @@ -725,11 +775,11 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substThetaUnchecked to -- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked :: Subst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked -subst_ty :: TCvSubst -> Type -> Type +subst_ty :: Subst -> Type -> Type -- subst_ty is the main workhorse for type substitution -- -- Note that the in_scope set is poked only if we hit a forall @@ -762,34 +812,44 @@ go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) go (CoercionTy co) = CoercionTy $! (subst_co subst co) -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv +substTyVar :: Subst -> TyVar -> Type +substTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv) $ case lookupVarEnv tenv tv of Just ty -> ty Nothing -> TyVarTy tv -substTyVars :: TCvSubst -> [TyVar] -> [Type] +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 -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars :: Subst -> [TyCoVar] -> [Type] substTyCoVars subst = map $ substTyCoVar subst -substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar :: Subst -> TyCoVar -> Type substTyCoVar subst tv | isTyVar tv = substTyVar subst tv | otherwise = CoercionTy $ substCoVar subst tv -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv +lookupTyVar :: Subst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubstEnv and CvSubstEnv] +lookupTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv ) lookupVarEnv tenv tv -- | Substitute within a 'Coercion' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCo :: HasDebugCallStack => TCvSubst -> Coercion -> Coercion +substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion substCo subst co | isEmptyTCvSubst subst = co | otherwise = checkValidSubst subst [] [co] $ subst_co subst co @@ -799,7 +859,7 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked :: Subst -> Coercion -> Coercion substCoUnchecked subst co | isEmptyTCvSubst subst = co | otherwise = subst_co subst co @@ -807,12 +867,12 @@ -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCos :: HasDebugCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion] substCos subst cos | isEmptyTCvSubst subst = cos | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos -subst_co :: TCvSubst -> Coercion -> Coercion +subst_co :: Subst -> Coercion -> Coercion subst_co subst co = go co where @@ -833,14 +893,14 @@ = 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) @@ -858,8 +918,8 @@ go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst = substForAllCoBndrUsing False (substCo subst) subst @@ -868,27 +928,27 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst = substForAllCoBndrUsing False (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] substForAllCoBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) + -> Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, KindCoercion) substForAllCoBndrUsing sym sco subst old_var | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + -> Subst -> TyVar -> KindCoercion + -> (Subst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv , new_var, new_kind_co ) where new_env | no_change && not sym = delVarEnv tenv old_var @@ -912,12 +972,12 @@ substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + -> Subst -> CoVar -> KindCoercion + -> (Subst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv , new_var, new_kind_co ) where new_cenv | no_change && not sym = delVarEnv cenv old_var @@ -935,31 +995,31 @@ new_var_type | sym = h2 | otherwise = h1 -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv +substCoVar :: Subst -> CoVar -> Coercion +substCoVar (Subst _ _ _ cenv) cv = case lookupVarEnv cenv cv of Just co -> co Nothing -> CoVarCo cv -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars :: Subst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v +lookupCoVar :: Subst -> Var -> Maybe Coercion +lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v -substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy -substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr -substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndr = substVarBndrUsing substTy -substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr -substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy -- | Like 'substVarBndr', but disables sanity checks. @@ -967,11 +1027,11 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUnchecked = substVarBndrUsing substTyUnchecked -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing :: (Subst -> Type -> Type) + -> Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v @@ -980,12 +1040,12 @@ -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) -- ^ Use this to substitute in the kind + -> Subst -> TyVar -> (Subst, TyVar) +substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $ assert (isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv, new_var) where new_env | no_change = delVarEnv tenv old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) @@ -998,7 +1058,7 @@ no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] + -- See Note [Extending the TvSubstEnv and CvSubstEnv] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any @@ -1015,11 +1075,11 @@ -- extended subst and a new covar. -- Use the supplied function to substitute in the kind substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) + -> Subst -> CoVar -> (Subst, CoVar) +substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assert (isCoVar old_var) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var) where new_co = mkCoVarCo new_var no_kind_change = noFreeVarsOfTypes [t1, t2] @@ -1038,11 +1098,14 @@ -- It's important to do the substitution for coercions, -- because they can have free type variables -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + ( Subst (extendInScopeSet in_scope tv') + id_env + (extendVarEnv tv_env tv (mkTyVarTy tv')) + cv_env + , tv') where old_ki = tyVarKind tv no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed @@ -1052,7 +1115,7 @@ tv' = setVarUnique tv1 uniq -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar]) cloneTyVarBndrs subst [] _usupply = (subst, []) cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) where @@ -1060,9 +1123,8 @@ (subst' , tv ) = cloneTyVarBndr subst t uniq (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' -substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, 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 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Tidying types and coercions for printing in error messages. @@ -13,10 +12,11 @@ tidyTyCoVarOcc, tidyTopType, tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders + tidyForAllTyBinder, tidyForAllTyBinders ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) @@ -70,24 +70,24 @@ -- this way is a helpful clue for users getHelpfulOccName tv | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") + = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0") | otherwise = occ where 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 --------------- @@ -174,14 +174,14 @@ -- 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) @@ -232,7 +232,7 @@ 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' @@ -242,7 +242,7 @@ 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 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -17,2928 +17,2866 @@ AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), TyConFlavour(..), - - -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConTyCoBinder, - mkNamedTyConBinder, mkNamedTyConBinders, - mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, - - -- ** Field labels - tyConFieldLabels, lookupTyConFieldLabel, - - -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkFunTyCon, - mkPrimTyCon, - mkTupleTyCon, - mkSumTyCon, - mkDataTyConRhs, - mkLevPolyDataTyConRhs, - mkSynonymTyCon, - mkFamilyTyCon, - mkPromotedDataCon, - mkTcTyCon, - noTcTyConScopedTyVars, - - -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, - isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, isPromotedTupleTyCon, - isLiftedAlgTyCon, - isTypeSynonymTyCon, - mustBeSaturated, - isPromotedDataCon, isPromotedDataCon_maybe, - isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, - - isDataTyCon, - isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isOpenFamilyTyCon, - isTypeFamilyTyCon, isDataFamilyTyCon, - isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, - tyConInjectivityInfo, - isBuiltInSynFamTyCon_maybe, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, - isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, - isImplicitTyCon, - isTyConWithSrcDataCons, - isTcTyCon, setTcTyConKind, - tcHasFixedRuntimeRep, - isConcreteTyCon, - - -- ** Extracting information out of TyCons - tyConName, - tyConSkolem, - tyConKind, - tyConUnique, - tyConTyVars, tyConVisibleTyVars, - tyConCType, tyConCType_maybe, - tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConAlgDataCons_maybe, - tyConSingleAlgDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, - tyConNullaryTy, - tyConRoles, - tyConFlavour, - tyConTuple_maybe, tyConClass_maybe, tyConATs, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - tyConFamilyResVar_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, - famTyConFlav_maybe, famTcResVar, - algTyConRhs, - newTyConRhs, newTyConEtadArity, newTyConEtadRhs, - unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, - newTyConDataCon_maybe, - algTcFields, - tyConRuntimeRepInfo, - tyConBinders, tyConResKind, tyConInvisTVBinders, - tcTyConScopedTyVars, tcTyConIsPoly, - mkTyConTagMap, - - -- ** Manipulating TyCons - expandSynTyCon_maybe, - newTyConCo, newTyConCo_maybe, - pprPromotionQuote, mkTyConKind, - - -- ** Predicated on TyConFlavours - tcFlavourIsOpen, - - -- * Runtime type representation - TyConRepName, tyConRepName_maybe, - mkPrelTyConRepName, - tyConRepModOcc, - - -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), - primElemRepToPrimRep, - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, - primRepIsFloat, - primRepsCompatible, - primRepCompatible, - primRepIsWord, - primRepIsInt, - -) where - -import GHC.Prelude -import GHC.Platform - -import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy ) -import {-# SOURCE #-} GHC.Core.TyCo.Ppr - ( pprType ) -import {-# SOURCE #-} GHC.Builtin.Types - ( runtimeRepTyCon, constraintKind, levityTyCon - , multiplicityTyCon - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) -import {-# SOURCE #-} GHC.Core.DataCon - ( DataCon, dataConFieldLabels - , dataConTyCon, dataConFullSig - , isUnboxedSumDataCon ) -import {-# SOURCE #-} GHC.Core.Type - ( isLiftedTypeKind ) -import GHC.Builtin.Uniques - ( tyConRepNameUnique - , dataConTyRepNameUnique ) - -import GHC.Utils.Binary -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.Class -import GHC.Types.Basic -import GHC.Types.ForeignCall -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Core.Coercion.Axiom -import GHC.Builtin.Names -import GHC.Data.Maybe -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString.Env -import GHC.Types.FieldLabel -import GHC.Settings.Constants -import GHC.Utils.Misc -import GHC.Types.Unique.Set -import GHC.Unit.Module - -import qualified Data.Data as Data - -{- ------------------------------------------------ - Notes about type families ------------------------------------------------ - -Note [Type synonym families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Type synonym families, also known as "type functions", map directly - onto the type functions in FC: - - type family F a :: * - type instance F Int = Bool - ..etc... - -* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon - -* From the user's point of view (F Int) and Bool are simply - equivalent types. - -* A Haskell 98 type synonym is a degenerate form of a type synonym - family. - -* Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! - -* Translation of type family decl: - type family F a :: * - translates to - a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - - type family G a :: * where - G Int = Bool - G Bool = Char - G a = () - translates to - a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the - appropriate CoAxiom representing the equations - -We also support injective type families -- see Note [Injective type families] - -Note [Data type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make - -* Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool - - Here T is the "family TyCon". - -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - -* The user does not see any "equivalent types" as they did with type - synonym families. They just see constructors with types - T1 :: T Int - T2 :: Bool -> T Int - -* Here's the FC version of the above declarations: - - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~R R:TInt - - Note that this is a *representational* coercion - The R:TInt is the "representation TyCons". - It has an AlgTyConFlav of - DataFamInstTyCon T [Int] ax_ti - -* The axiom ax_ti may be eta-reduced; see - Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - -* Data family instances may have a different arity than the data family. - See Note [Arity of data families] in GHC.Core.FamInstEnv - -* The data constructor T2 has a wrapper (which is what the - source-level "T2" invokes): - - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti - -* A data instance can declare a fully-fledged GADT: - - data instance T (a,b) where - X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) - - Here's the FC version of the above declaration: - - data R:TPair a b where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~R R:TPair a b - - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) - - The R:TPair are the "representation TyCons". - We have a bit of work to do, to unpick the result types of the - data instance declaration for T (a,b), to get the result type in the - representation; e.g. T (a,b) --> R:TPair a b - - The representation TyCon R:TList, has an AlgTyConFlav of - - DataFamInstTyCon T [(a,b)] ax_pr - -* Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced - into R:TInt, R:TPair by the axioms. These axioms - axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching - Rather like newtype, in fact - - As a result - - - T behaves just like a data type so far as decomposition is concerned - - - (T Int) is not implicitly converted to R:TInt during type inference. - Indeed the latter type is unknown to the programmer. - - - There *is* an instance for (T Int) in the type-family instance - environment, but it is looked up (via tcLookupDataFamilyInst) - in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to - solve representational equalities like - T Int ~R# Bool - Here we look up (T Int), convert it to R:TInt, and then unwrap the - newtype R:TInt. - - It is also looked up in reduceTyFamApp_maybe. - - - It's fine to have T in the LHS of a type function: - type instance F (T a) = [a] - - It was this last point that confused me! The big thing is that you - should not think of a data family T as a *type function* at all, not - even an injective one! We can't allow even injective type functions - on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool - is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char - - So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. - -* The tyConTyVars of the representation tycon are the tyvars that the - user wrote in the patterns. This is important in GHC.Tc.Deriv, where we - bring these tyvars into scope before type-checking the deriving - clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. - -Note [Associated families and their parent class] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Associated* families are just like *non-associated* families, except -that they have a famTcParent field of (Just cls_tc), which identifies the -parent class. - -However there is an important sharing relationship between - * the tyConTyVars of the parent Class - * the tyConTyVars of the associated TyCon - - class C a b where - data T p a - type F a q b - -Here the 'a' and 'b' are shared with the 'Class'; that is, they have -the same Unique. - -This is important. In an instance declaration we expect - * all the shared variables to be instantiated the same way - * the non-shared variables of the associated type should not - be instantiated at all - - instance C [x] (Tree y) where - data T p [x] = T1 x | T2 p - type F [x] q (Tree y) = (x,y,q) - -Note [TyCon Role signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every tycon has a role signature, assigning a role to each of the tyConTyVars -(or of equal length to the tyConArity, if there are no tyConTyVars). An -example demonstrates these best: say we have a tycon T, with parameters a at -nominal, b at representational, and c at phantom. Then, to prove -representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have -nominal equality between a1 and a2, representational equality between b1 and -b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This -might happen, say, with the following declaration: - - data T a b c where - MkT :: b -> T Int b c - -Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), -as do vanilla synonym tycons. Family tycons have all parameters at role N, -though it is conceivable that we could relax this restriction. (->)'s and -tuples' parameters are at role R. Each primitive tycon declares its roles; -it's worth noting that (~#)'s parameters are at role N. Promoted data -constructors' type arguments are at role R. All kind arguments are at role -N. - -Note [Unboxed tuple RuntimeRep vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may have any representation. Accordingly, -the kind of the unboxed tuple constructor is runtime-representation -polymorphic. - -Type constructor (2 kind arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). - TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) -Data constructor (4 type arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) - (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) - -These extra tyvars (q and r) cause some delicate processing around tuples, -where we need to manually insert RuntimeRep arguments. -The same situation happens with unboxed sums: each alternative -has its own RuntimeRep. -For boxed tuples, there is no representation polymorphism, and therefore -we add RuntimeReps only for the unboxed version. - -Type constructor (no kind arguments) - (,) :: Type -> Type -> Type -Data constructor (2 type arguments) - (,) :: forall a b. a -> b -> (a, b) - - -Note [Injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow injectivity annotations for type families (both open and closed): - - type family F (a :: k) (b :: k) = r | r -> a - type family G a b = res | res -> a b where ... - -Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. -`famTcInj` maybe stores a list of Bools, where each entry corresponds to a -single element of `tyConTyVars` (both lists should have identical length). If no -injectivity annotation was provided `famTcInj` is Nothing. From this follows an -invariant that if `famTcInj` is a Just then at least one element in the list -must be True. - -See also: - * [Injectivity annotation] in GHC.Hs.Decls - * [Renaming injectivity annotation] in GHC.Rename.Module - * [Verifying injectivity annotation] in GHC.Core.FamInstEnv - * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact - -Note [Sharing nullary TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nullary type constructor applications are extremely common. For this reason -each TyCon carries with it a @TyConApp tycon []@. This ensures that -'mkTyConTy' does not need to allocate and eliminates quite a bit of heap -residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', -ensuring that this function also benefits from sharing. - -This optimisation improves allocations in the Cabal test by around 0.3% and -decreased cache misses measurably. - -See #19367. - - -************************************************************************ -* * - TyConBinder, TyConTyCoBinder -* * -************************************************************************ --} - -type TyConBinder = VarBndr TyVar TyConBndrVis -type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis - -- Only PromotedDataCon has TyConTyCoBinders - -- See Note [Promoted GADT data constructors] - -data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB AnonArgFlag - -instance Outputable TyConBndrVis where - ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag - ppr (AnonTCB af) = text "AnonTCB" <> ppr af - -mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder -mkAnonTyConBinder af tv = assert (isTyVar tv) $ - Bndr tv (AnonTCB af) - -mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] -mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs - -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder --- The odd argument order supports currying -mkNamedTyConBinder vis tv = assert (isTyVar tv) $ - Bndr tv (NamedTCB vis) - -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] --- The odd argument order supports currying -mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs - --- | Make a Required TyConBinder. It chooses between NamedTCB and --- AnonTCB based on whether the tv is mentioned in the dependent set -mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently - -> TyVar - -> TyConBinder -mkRequiredTyConBinder dep_set tv - | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder VisArg tv - -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis - -tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag -tyConBndrVisArgFlag (NamedTCB vis) = vis -tyConBndrVisArgFlag (AnonTCB VisArg) = Required -tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] - -isNamedTyConBinder :: TyConBinder -> Bool --- Identifies kind variables --- E.g. data T k (a:k) = blah --- Here 'k' is a NamedTCB, a variable used in the kind of other binders -isNamedTyConBinder (Bndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False - -isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis - -isVisibleTcbVis :: TyConBndrVis -> Bool -isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis -isVisibleTcbVis (AnonTCB VisArg) = True -isVisibleTcbVis (AnonTCB InvisArg) = False - -isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) - --- Build the 'tyConKind' from the binders and the result kind. --- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. -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 - -tyConInvisTVBinders :: [TyConBinder] -- From the TyCon - -> [InvisTVBinder] -- Suitable for the foralls of a term function --- See Note [Building TyVarBinders from TyConBinders] -tyConInvisTVBinders tc_bndrs - = map mk_binder tc_bndrs - where - 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] - NamedTCB Required -> SpecifiedSpec - NamedTCB (Invisible vis) -> vis - --- Returns only tyvars, as covars are always inferred -tyConVisibleTyVars :: TyCon -> [TyVar] -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 -can arise in one of two ways: - -* In a PromotedDataCon whose kind has an equality constraint: - - 'MkT :: forall a b. (a~b) => blah - - 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 -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 -provide it. It would be utterly wrong to do this for constraint -arguments, which is why AnonTCB must have the AnonArgFlag in -the first place. - -Note [Building TyVarBinders from TyConBinders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We sometimes need to build the quantified type of a value from -the TyConBinders of a type or class. For that we need not -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 - - * 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 - -Both of these are user-callable. (NB: default methods are not callable -directly by the user but rather via the code generated by 'deriving', -which uses visible type application; see mkDefMethBind.) - -Since they are user-callable we must get their type-argument visibility -information right; and that info is in the TyConBinders. -Here is an example: - - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * - -The TyCon has - - tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] - -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 - - dataConUnivTyVarBinders = [ Bndr (k:*) Inferred - , Bndr (a:k->*) Specified - , Bndr (b:k) Specified ] - -So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - - variable names from the TyConBinders - - but changing Anon/Required to Specified - -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 --} - - -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConTyCoBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders - -- NB: Currently (Aug 2018), TyCons that own this - -- field really only contain TyVars. So it is - -- [TyVar] instead of [TyCoVar]. - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of type/coercion variables on the LHS of the - type declaration. For example: - - type App a (b :: k) = a b - - tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) - , Bndr (a:k->*) AnonTCB - , Bndr (b:k) AnonTCB ] - - Note that there are three binders here, including the - kind variable k. - - See Note [tyConBinders and lexical scoping] - -* See Note [VarBndrs, TyCoVarBinders, 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 - that TyVar may scope over some other part of the TyCon's definition. Eg - type T a = a -> a - we have - tyConBinders = [ Bndr (a:*) AnonTCB ] - synTcRhs = a -> a - So the 'a' scopes over the synTcRhs - -* From the tyConBinders and tyConResKind we can get the tyConKind - E.g for our App example: - App :: forall k. (k->*) -> k -> * - - We get a 'forall' in the kind for each NamedTCB, and an arrow - for each AnonTCB - - tyConKind is the full kind of the TyCon, not just the result kind - -* For type families, tyConArity is the arguments this TyCon must be - applied to, to be considered saturated. Here we mean "applied to in - the actual Type", not surface syntax; i.e. including implicit kind - variables. So it's just (length tyConBinders) - -* For an algebraic data type, or data instance, the tyConResKind is - always (TYPE r); that is, the tyConBinders are enough to saturate - the type constructor. I'm not quite sure why we have this invariant, - but it's enforced by splitTyConKind - -Note [tyConBinders and lexical scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a TyCon, and a PolyTcTyCon, we obey the following rule: - - The Name of the TyConBinder is precisely - the lexically scoped Name from the original declaration - (precisely = both OccName and Unique) - -For example, - data T a (b :: wombat) = MkT -We will get tyConBinders of [k, wombat, a::k, b::wombat] -The 'k' is made up; the user didn't specify it. But for the kind of 'b' -we must use 'wombat'. - -Why do we have this invariant? - -* Similarly, when typechecking default definitions for class methods, in - GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; - but the variables bound in that class must be in scope. Eample (#19738): - - type P :: k -> Type - data P a = MkP - - type T :: k -> Constraint - class T (a :: j) where - f :: P a - f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' - -* When typechecking `deriving` clauses for top-level data declarations, the - tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` - field of GHC.Tc.Deriv.DerivInfo. Example (#16731): - - class C x1 x2 - - type T :: a -> Type - data T (x :: z) deriving (C z) - - When typechecking `C z`, we want `z` to map to `a`, which is exactly what the - tcTyConScopedTyVars for T give us. --} - -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" - -instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } - put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { af <- get bh; return (AnonTCB af) } - _ -> do { vis <- get bh; return (NamedTCB vis) } } - - -{- ********************************************************************* -* * - The TyCon type -* * -************************************************************************ --} - - --- | TyCons represent type constructors. Type constructors are introduced by --- things such as: --- --- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ --- --- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor --- --- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ --- --- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ --- --- This data type also encodes a number of primitive, built in type constructors --- such as those for function and tuple types. - --- 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 - } - - -- | Algebraic data types, from - -- - @data@ declarations - -- - @newtype@ declarations - -- - data instance declarations - -- - type instance declarations - -- - the TyCon generated by a class declaration - -- - boxed tuples - -- - unboxed tuples - -- - constraint tuples - -- - 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. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - -- The tyConTyVars scope over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType,-- ^ The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT - -- syntax? If so, that doesn't mean it's a - -- true GADT; only that the "where" form - -- was used. This field is used only to - -- guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data - -- type (always empty for GADTs). A - -- \"stupid theta\" is the context to - -- the left of an algebraic type - -- declaration, e.g. @Eq a@ in the - -- declaration @data Eq a => T a ...@. - -- See @Note [The stupid context]@ in - -- "GHC.Core.DataCon". - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcFields :: FieldLabelEnv, -- ^ Maps a label to information - -- about the field - - algTcFlavour :: AlgTyConFlav -- ^ The flavour of this algebraic tycon. - -- Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - - } - - -- | Represents type synonyms - | SynonymTyCon { - 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 - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - -- tyConTyVars scope over: synTcRhs - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - synTcRhs :: Type, -- ^ Contains information about the expansion - -- of the synonym - - synIsTau :: Bool, -- True <=> the RHS of this synonym does not - -- have any foralls, after expanding any - -- nested synonyms - synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention - -- any type synonym families (data families - -- are fine), again after expanding any - -- nested synonyms - synIsForgetful :: Bool -- True <= at least one argument is not mentioned - -- in the RHS (or is mentioned only under - -- forgetful synonyms) - -- Test is conservative, so True does not guarantee - -- forgetfulness. - } - - -- | Represents families (both type and data) - -- Argument roles are all Nominal - | FamilyTyCon { - 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 - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - -- tyConTyVars connect an associated family TyCon - -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst - - famTcResVar :: Maybe Name, -- ^ Name of result type variable, used - -- for pretty-printing with --show-iface - -- and for reifying TyCon in Template - -- Haskell - - famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, - -- abstract, built-in. See comments for - -- FamTyConFlav - - famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families - -- The class tycon in which the family is declared - -- See Note [Associated families and their parent class] - - famTcInj :: Injectivity -- ^ is this a type family injective in - -- its type variables? Nothing if no - -- injectivity annotation was given - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- 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. - - 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, -- ^ A pre-allocated @TyConApp tycon []@ - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - primRepName :: TyConRepName -- ^ The 'Typeable' representation. - -- A cached version of - -- @'mkPrelTyConRepName' ('tyConName' tc)@. - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - 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 construtors] - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp 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' - } - - -- | These exist only during type-checking. See Note [How TcTyCons work] - -- in "GHC.Tc.TyCl" - | TcTyCon { - tyConUnique :: Unique, - tyConName :: Name, - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - -- NB: the TyConArity of a TcTyCon must match - -- the number of Required (positional, user-specified) - -- arguments to the type constructor; see the use - -- of tyConArity in generaliseTcTyCon - - tcTyConScopedTyVars :: [(Name,TcTyVar)], - -- ^ Scoped tyvars over the tycon's body - -- The range is always a skolem or TcTyVar, be - -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] - - tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? - -- Used only to make zonking more efficient - - tcTyConFlavour :: TyConFlavour - -- ^ What sort of 'TyCon' this represents. - } - -{- Note [Scoped tyvars in a TcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcTyConScopedTyVars field records the lexicial-binding connection -between the original, user-specified Name (i.e. thing in scope) and -the TcTyVar that the Name is bound to. - -Order *does* matter; the tcTyConScopedTyvars list consists of - specified_tvs ++ required_tvs - -where - * specified ones first - * required_tvs the same as tyConTyVars - * tyConArity = length required_tvs - -tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons. -See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType. - -Note [Promoted GADT data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Any promoted GADT data constructor will have a type with equality -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, -but with the clue that the binder can be a CoVar not just a TyVar. - -Note [Representation-polymorphic TyCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To check for representation-polymorphism directly in the typechecker, -e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep, -we need to compute whether a type has a syntactically fixed RuntimeRep, -as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. - -It's useful to have a quick way to check whether a saturated application -of a type constructor has a fixed RuntimeRep. That is, we want -to know, given a TyCon 'T' of arity 'n', does - - T a_1 ... a_n - -always have a fixed RuntimeRep? That is, is it always the case -that this application has a kind of the form - - T a_1 ... a_n :: TYPE rep - -in which 'rep' is a concrete 'RuntimeRep'? -('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete: -it contains no type-family applications or type variables.) - -To answer this question, we have 'tcHasFixedRuntimeRep'. -If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that -every saturated application of `T` has a fixed RuntimeRep. -However, if it returns 'False', we don't know: perhaps some application might not -have a fixed RuntimeRep. - -Examples: - - - For type families, we won't know in general whether an application - will have a fixed RuntimeRep: - - type F :: k -> k - type family F a where {..} - - `tcHasFixedRuntimeRep F = False' - - - For newtypes, we're usually OK: - - newtype N a b c = MkN Int - - No matter what arguments we apply `N` to, we always get something of - kind `Type`, which has a fixed RuntimeRep. - Thus `tcHasFixedRuntimeRep N = True`. - - However, with `-XUnliftedNewtypes`, we can have representation-polymorphic - newtypes: - - type UN :: TYPE rep -> TYPE rep - newtype UN a = MkUN a - - `tcHasFixedRuntimeRep UN = False` - - For example, `UN @Int8Rep Int8#` is represented by an 8-bit value, - while `UN @LiftedRep Int` is represented by a heap pointer. - - To distinguish whether we are dealing with a representation-polymorphic newtype, - we keep track of which situation we are in using the 'nt_fixed_rep' - field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field - to compute 'tcHasFixedRuntimeRep'. - - - A similar story can be told for datatypes: we're usually OK, - except with `-XUnliftedDatatypes` which allows for levity polymorphism, - e.g.: - - type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l) - type UC a = MkUC a - - `tcHasFixedRuntimeRep UC = False` - - Here, we keep track of whether we are dealing with a levity-polymorphic - unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon' - constructor of 'AlgTyConRhs'. - - N.B.: technically, the representation of a datatype is fixed, - as it is always a pointer. However, we currently require that we - know the specific `RuntimeRep`: knowing that it's `BoxedRep l` - for a type-variable `l` isn't enough. See #15532. --} - --- | Represents right-hand-sides of 'TyCon's for algebraic types -data AlgTyConRhs - - -- | Says that we know nothing about this data type, except that - -- it's represented by a pointer. Used when we export a data type - -- abstractly into an .hi file. - = AbstractTyCon - - -- | Information about those 'TyCon's derived from a @data@ - -- declaration. This includes data types with no constructors at - -- all. - | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the - -- user declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' - -- tag (see the tag assignment in mkTyConTagMap) - data_cons_size :: Int, - -- ^ Cached value: length data_cons - is_enum :: Bool, -- ^ Cached value: is this an enumeration type? - -- See Note [Enumeration types] - data_fixed_lev :: Bool - -- ^ 'True' if the data type constructor has - -- a known, fixed levity when fully applied - -- to its arguments, False otherwise. - -- - -- This can only be 'False' with UnliftedDatatypes, - -- e.g. - -- - -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A } - -- - -- This boolean is cached to make it cheaper to check - -- for levity and representation-polymorphism in - -- tcHasFixedRuntimeRep. - } - - | TupleTyCon { -- A boxed, unboxed, or constraint tuple - data_con :: DataCon, -- NB: it can be an *unboxed* tuple - tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint - -- tuple? - } - - -- | An unboxed sum type. - | SumTyCon { - data_cons :: [DataCon], - data_cons_size :: Int -- ^ Cached value: length data_cons - } - - -- | Information about those 'TyCon's derived from a @newtype@ declaration - | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. - -- It has no existentials - - nt_rhs :: Type, -- ^ Cached value: the argument type of the - -- constructor, which is just the representation - -- type of the 'TyCon' (remember that @newtype@s - -- do not exist at runtime so need a different - -- representation type). - -- - -- The free 'TyVar's of this type are the - -- 'tyConTyVars' from the corresponding 'TyCon' - - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom Unbranched, - -- The axiom coercion that creates the @newtype@ - -- from the representation 'Type'. The axiom witnesses - -- a representational coercion: - -- nt_co :: N ty1 ~R# rep_tys - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check #1072. - nt_fixed_rep :: Bool - -- ^ 'True' if the newtype has a known, fixed representation - -- when fully applied to its arguments, 'False' otherwise. - -- This can only ever be 'False' with UnliftedNewtypes. - -- - -- Example: - -- - -- > newtype N (a :: TYPE r) = MkN a - -- - -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt) - -- - -- This boolean is cached to make it cheaper to check if a - -- variable binding is representation-polymorphic - -- in tcHasFixedRuntimeRep. - } - -mkSumTyConRhs :: [DataCon] -> AlgTyConRhs -mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) - --- | Create an 'AlgTyConRhs' from the data constructors, --- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`). -mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity - -> [DataCon] - -> AlgTyConRhs -mkLevPolyDataTyConRhs fixed_lev cons - = DataTyCon { - data_cons = cons, - data_cons_size = length cons, - is_enum = not (null cons) && all is_enum_con cons, - -- See Note [Enumeration types] in GHC.Core.TyCon - data_fixed_lev = fixed_lev - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - --- | Create an 'AlgTyConRhs' from the data constructors. --- --- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic. -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs = mkLevPolyDataTyConRhs False - --- | Some promoted datacons signify extra info relevant to GHC. For example, --- 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. --- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> [PrimRep]) - -- ^ 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@ - --- | Extract those 'DataCon's that we are able to learn about. Note --- that visibility in this sense does not correspond to visibility in --- the context of any particular user program! -visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons (DataTyCon{ data_cons = cs }) = cs -visibleDataCons (NewTyCon{ data_con = c }) = [c] -visibleDataCons (TupleTyCon{ data_con = c }) = [c] -visibleDataCons (SumTyCon{ data_cons = cs }) = cs - --- | Describes the flavour of an algebraic type constructor. For --- classes and data families, this flavour includes a reference to --- the parent 'TyCon'. -data AlgTyConFlav - = -- | An ordinary algebraic type constructor. This includes unlifted and - -- representation-polymorphic datatypes and newtypes and unboxed tuples, - -- but NOT unboxed sums; see UnboxedSumTyCon. - VanillaAlgTyCon - TyConRepName -- For Typeable - - -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon - -- because we currently don't allow unboxed sums to be Typeable since - -- there are too many of them. See #13276. - | UnboxedSumTyCon - - -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" - | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the - -- current tycon - TyConRepName - - -- | Type constructors representing an *instance* of a *data* family. - -- Parameters: - -- - -- 1) The type family in question - -- - -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: - -- the number of types matches the arity of the family 'TyCon' - -- - -- 3) A 'CoTyCon' identifying the representation - -- type with the type instance family - | DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion axiom. - -- A *Representational* coercion, - -- of kind T ty1 ty2 ~R R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon - -- - -- BUT may be eta-reduced; see - -- Note [Eta reduction for data families] in - -- GHC.Core.Coercion.Axiom - - -- Cached fields of the CoAxiom, but adjusted to - -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv - - -- E.g. data instance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co - -instance Outputable AlgTyConFlav where - ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" - ppr (UnboxedSumTyCon {}) = text "Unboxed sum" - ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls - ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" - <+> ppr tc <+> sep (map pprType tys) - --- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class --- name, if any -okParent :: Name -> AlgTyConFlav -> Bool -okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedSumTyCon {}) = True -okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) -okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc - -isNoParent :: AlgTyConFlav -> Bool -isNoParent (VanillaAlgTyCon {}) = True -isNoParent _ = False - --------------------- - -data Injectivity - = NotInjective - | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) - deriving( Eq ) - --- | Information pertaining to the expansion of a type synonym (@type@) -data FamTyConFlav - = -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data family T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - DataFamilyTyCon - TyConRepName - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon - - -- | A closed type synonym family e.g. - -- @type family F x where { F Int = Bool }@ - | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) - -- See Note [Closed type families] - - -- | A closed type synonym family declared in an hs-boot file with - -- type family F a where .. - | AbstractClosedSynFamilyTyCon - - -- | Built-in type family used by the TypeNats solver - | BuiltInSynFamTyCon BuiltInSynFamily - -instance Outputable FamTyConFlav where - ppr (DataFamilyTyCon n) = text "data family" <+> ppr n - ppr OpenSynFamilyTyCon = text "open type family" - ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" - ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax - ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" - ppr (BuiltInSynFamTyCon _) = text "built-in type family" - -{- Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* In an open type family you can add new instances later. This is the - usual case. - -* In a closed type family you can only put equations where the family - is defined. - -A non-empty closed type family has a single axiom with multiple -branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed -type family with no equations does not have an axiom, because there is -nothing for the axiom to prove! - - -Note [Promoted data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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) - -* We promote the *user* type of the DataCon. Eg - data T = MkT {-# UNPACK #-} !(Bool, Bool) - The promoted kind is - 'MkT :: (Bool,Bool) -> T - *not* - 'MkT :: Bool -> Bool -> T - -* Similarly for GADTs: - data G a where - MkG :: forall b. b -> G [b] - The promoted data constructor has kind - 'MkG :: forall b. b -> G [b] - *not* - 'MkG :: forall a b. (a ~# [b]) => b -> G a - -Note [Enumeration types] -~~~~~~~~~~~~~~~~~~~~~~~~ -We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we -end up generating an empty table for - __closure_tbl -which is used by tagToEnum# to map Int# to constructors -in an enumeration. The empty table apparently upset -the linker. - -Moreover, all the data constructor must be enumerations, meaning -they have type (forall abc. T a b c). GADTs are not enumerations. -For example consider - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a -What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. -See #4528. - -Note [Newtype coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a CoAxiom which is used for coercing from -the representation type of the newtype, to the newtype itself. For -example, - - newtype T a = MkT (a -> a) - -the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. - -We might also eta-contract the axiom: see Note [Newtype eta]. - -Note [Newtype eta] -~~~~~~~~~~~~~~~~~~ -Consider - newtype Parser a = MkParser (IO a) deriving Monad -Are these two types equal? That is, does a coercion exist between them? - Monad Parser - Monad IO -(We need this coercion to make the derived instance for Monad Parser.) - -Well, yes. But to see that easily we eta-reduce the RHS type of -Parser, in this case to IO, so that even unsaturated applications of -Parser will work right. So instead of - axParser :: forall a. Parser a ~ IO a -we generate an eta-reduced axiom - axParser :: Parser ~ IO - -This eta reduction is done when the type constructor is built, in -GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon. - -Here's an example that I think showed up in practice. -Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) - - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) - -After desugaring, and discarding the data constructors for the newtypes, -we would like to get: - w2 = w1 `cast` Foo axT - -so that w2 and w1 share the same code. To do this, the coercion axiom -axT must have - kind: axT :: T ~ [] - and arity: 0 - -See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. - -************************************************************************ -* * - TyConRepName -* * -********************************************************************* -} - -type TyConRepName = Name - -- The Name of the top-level declaration for the Typeable world - -- $tcMaybe :: Data.Typeable.Internal.TyCon - -- $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 - VanillaAlgTyCon rep_nm -> Just rep_nm - UnboxedSumTyCon -> Nothing - ClassTyCon _ rep_nm -> Just rep_nm - DataFamInstTyCon {} -> Nothing -tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) - = Just rep_nm -tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) - | isUnboxedSumDataCon dc -- see #13276 - = Nothing - | otherwise - = Just rep_nm -tyConRepName_maybe _ = Nothing - --- | Make a 'Name' for the 'Typeable' representation of the given wired-in type -mkPrelTyConRepName :: Name -> TyConRepName --- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". -mkPrelTyConRepName tc_name -- Prelude tc_name is always External, - -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) - where - name_occ = nameOccName tc_name - name_mod = nameModule tc_name - name_uniq = nameUnique tc_name - rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq - | otherwise = dataConTyRepNameUnique name_uniq - (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ - --- | The name (and defining module) for the Typeable representation (TyCon) of a --- type constructor. --- --- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". -tyConRepModOcc :: Module -> OccName -> (Module, OccName) -tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) - where - rep_module - | tc_module == gHC_PRIM = gHC_TYPES - | otherwise = tc_module - - -{- ********************************************************************* -* * - PrimRep -* * -************************************************************************ - -Note [rep swamp] -~~~~~~~~~~~~~~~~ -GHC has a rich selection of types that represent "primitive types" of -one kind or another. Each of them makes a different set of -distinctions, and mostly the differences are for good reasons, -although it's probably true that we could merge some of these. - -Roughly in order of "includes more information": - - - A Width ("GHC.Cmm.Type") is simply a binary value with the specified - number of bits. It may represent a signed or unsigned integer, a - floating-point value, or an address. - - data Width = W8 | W16 | W32 | W64 | W128 - - - Size, which is used in the native code generator, is Width + - floating point information. - - data Size = II8 | II16 | II32 | II64 | FF32 | FF64 - - it is necessary because e.g. the instruction to move a 64-bit float - on x86 (movsd) is different from the instruction to move a 64-bit - integer (movq), so the mov instruction is parameterised by Size. - - - CmmType wraps Width with more information: GC ptr, float, or - other value. - - data CmmType = CmmType CmmCat Width - - data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - - It is important to have GcPtr information in Cmm, since we generate - info tables containing pointerhood for the GC from this. As for - why we have float (and not signed/unsigned) here, see Note [Signed - vs unsigned]. - - - ArgRep makes only the distinctions necessary for the call and - return conventions of the STG machine. It is essentially CmmType - + void. - - - PrimRep makes a few more distinctions than ArgRep: it divides - non-GC-pointers into signed/unsigned and addresses, information - that is necessary for passing these values to foreign functions. - -There's another tension here: whether the type encodes its size in -bytes, or whether its size depends on the machine word size. Width -and CmmType have the size built-in, whereas ArgRep and PrimRep do not. - -This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. - -On the other hand, CmmType includes some "nonsense" values, such as -CmmType GcPtrCat W32 on a 64-bit machine. - -The PrimRep type is closely related to the user-visible RuntimeRep type. -See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. - --} - --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, --- and store values of this type. See also Note [RuntimeRep and PrimRep] in --- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". -data PrimRep - = VoidRep - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value - | Int32Rep -- ^ Signed, 32-bit value - | Int64Rep -- ^ Signed, 64 bit value - | IntRep -- ^ Signed, word-sized value - | Word8Rep -- ^ Unsigned, 8 bit value - | Word16Rep -- ^ Unsigned, 16 bit value - | Word32Rep -- ^ Unsigned, 32 bit value - | Word64Rep -- ^ Unsigned, 64 bit value - | WordRep -- ^ Unsigned, word-sized value - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') - | FloatRep - | DoubleRep - | VecRep Int PrimElemRep -- ^ A vector - deriving( Data.Data, Eq, Ord, Show ) - -data PrimElemRep - = Int8ElemRep - | Int16ElemRep - | Int32ElemRep - | Int64ElemRep - | Word8ElemRep - | Word16ElemRep - | Word32ElemRep - | Word64ElemRep - | FloatElemRep - | DoubleElemRep - deriving( Data.Data, Eq, Ord, Show, Enum ) - -instance Outputable PrimRep where - ppr r = text (show r) - -instance Outputable PrimElemRep where - ppr r = text (show r) - -instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 - put_ bh LiftedRep = putByte bh 1 - put_ bh UnliftedRep = putByte bh 2 - put_ bh Int8Rep = putByte bh 3 - put_ bh Int16Rep = putByte bh 4 - put_ bh Int32Rep = putByte bh 5 - put_ bh Int64Rep = putByte bh 6 - put_ bh IntRep = putByte bh 7 - put_ bh Word8Rep = putByte bh 8 - put_ bh Word16Rep = putByte bh 9 - put_ bh Word32Rep = putByte bh 10 - put_ bh Word64Rep = putByte bh 11 - put_ bh WordRep = putByte bh 12 - put_ bh AddrRep = putByte bh 13 - put_ bh FloatRep = putByte bh 14 - put_ bh DoubleRep = putByte bh 15 - put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per - get bh = do - h <- getByte bh - case h of - 0 -> pure VoidRep - 1 -> pure LiftedRep - 2 -> pure UnliftedRep - 3 -> pure Int8Rep - 4 -> pure Int16Rep - 5 -> pure Int32Rep - 6 -> pure Int64Rep - 7 -> pure IntRep - 8 -> pure Word8Rep - 9 -> pure Word16Rep - 10 -> pure Word32Rep - 11 -> pure Word64Rep - 12 -> pure WordRep - 13 -> pure AddrRep - 14 -> pure FloatRep - 15 -> pure DoubleRep - 16 -> VecRep <$> get bh <*> get bh - _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) - -instance Binary PrimElemRep where - put_ bh per = putByte bh (fromIntegral (fromEnum per)) - get bh = toEnum . fromIntegral <$> getByte bh - -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - -isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = True -isGcPtrRep _ = False - --- A PrimRep is compatible with another iff one can be coerced to the other. --- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. -primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool -primRepCompatible platform rep1 rep2 = - (isUnboxed rep1 == isUnboxed rep2) && - (primRepSizeB platform rep1 == primRepSizeB platform rep2) && - (primRepIsFloat rep1 == primRepIsFloat rep2) - where - isUnboxed = not . isGcPtrRep - --- More general version of `primRepCompatible` for types represented by zero or --- more than one PrimReps. -primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool -primRepsCompatible platform reps1 reps2 = - length reps1 == length reps2 && - and (zipWith (primRepCompatible platform) reps1 reps2) - --- | The size of a 'PrimRep' in bytes. --- --- This applies also when used in a constructor, where we allow packing the --- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will --- take only 8 bytes, which for 64-bit arch will be equal to 1 word. --- See also mkVirtHeapOffsetsWithPadding for details of how data fields are --- laid out. -primRepSizeB :: Platform -> PrimRep -> Int -primRepSizeB platform = \case - IntRep -> platformWordSizeInBytes platform - WordRep -> platformWordSizeInBytes platform - Int8Rep -> 1 - Int16Rep -> 2 - Int32Rep -> 4 - Int64Rep -> 8 - Word8Rep -> 1 - Word16Rep -> 2 - Word32Rep -> 4 - Word64Rep -> 8 - FloatRep -> fLOAT_SIZE - DoubleRep -> dOUBLE_SIZE - AddrRep -> platformWordSizeInBytes platform - LiftedRep -> platformWordSizeInBytes platform - UnliftedRep -> platformWordSizeInBytes platform - VoidRep -> 0 - (VecRep len rep) -> len * primElemRepSizeB platform rep - -primElemRepSizeB :: Platform -> PrimElemRep -> Int -primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep - -primElemRepToPrimRep :: PrimElemRep -> PrimRep -primElemRepToPrimRep Int8ElemRep = Int8Rep -primElemRepToPrimRep Int16ElemRep = Int16Rep -primElemRepToPrimRep Int32ElemRep = Int32Rep -primElemRepToPrimRep Int64ElemRep = Int64Rep -primElemRepToPrimRep Word8ElemRep = Word8Rep -primElemRepToPrimRep Word16ElemRep = Word16Rep -primElemRepToPrimRep Word32ElemRep = Word32Rep -primElemRepToPrimRep Word64ElemRep = Word64Rep -primElemRepToPrimRep FloatElemRep = FloatRep -primElemRepToPrimRep DoubleElemRep = DoubleRep - --- | Return if Rep stands for floating type, --- returns Nothing for vector types. -primRepIsFloat :: PrimRep -> Maybe Bool -primRepIsFloat FloatRep = Just True -primRepIsFloat DoubleRep = Just True -primRepIsFloat (VecRep _ _) = Nothing -primRepIsFloat _ = Just False - --- Rep is one of the word reps. -primRepIsWord :: PrimRep -> Bool -primRepIsWord WordRep = True -primRepIsWord (Word8Rep) = True -primRepIsWord (Word16Rep) = True -primRepIsWord (Word32Rep) = True -primRepIsWord (Word64Rep) = True -primRepIsWord _ = False - --- Rep is one of the int reps. -primRepIsInt :: PrimRep -> Bool -primRepIsInt (IntRep) = True -primRepIsInt (Int8Rep) = True -primRepIsInt (Int16Rep) = True -primRepIsInt (Int32Rep) = True -primRepIsInt (Int64Rep) = True -primRepIsInt _ = False - -{- -************************************************************************ -* * - Field labels -* * -************************************************************************ --} - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabels :: TyCon -> [FieldLabel] -tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabelEnv :: TyCon -> FieldLabelEnv -tyConFieldLabelEnv tc - | isAlgTyCon tc = algTcFields tc - | otherwise = emptyDFsEnv - --- | Look up a field label belonging to this 'TyCon' -lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel -lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl - --- | Make a map from strings to FieldLabels from all the data --- constructors of this algebraic tycon -fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv -fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) - | fl <- dataConsFields (visibleDataCons rhs) ] - where - -- Duplicates in this list will be removed by 'mkFsEnv' - dataConsFields dcs = concatMap dataConFieldLabels dcs - - -{- -************************************************************************ -* * -\subsection{TyCon Construction} -* * -************************************************************************ - -Note: the TyCon constructors all take a Kind as one argument, even though -they could, in principle, work out their Kind from their other arguments. -But to do so they need functions from Types, and that makes a nasty -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' - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> TyCon -mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = let tc = - AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcFlavour = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent, - algTcGadtSyntax = gadt_syn - } - in tc - --- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyConBinder] - -> [Role] -> AlgTyConRhs -> Class - -> Name -> TyCon -mkClassTyCon name binders roles rhs clas tc_rep_name - = mkAlgTyCon name binders constraintKind roles Nothing [] rhs - (ClassTyCon clas tc_rep_name) - False - -mkTupleTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple 'TyCon' - -> DataCon - -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> AlgTyConFlav - -> TyCon -mkTupleTyCon name binders res_kind arity con sort parent - = let tc = - AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcFlavour = parent - } - in tc - -mkSumTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Kind of the resulting 'TyCon' - -> Arity -- ^ Arity of the sum - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> [DataCon] - -> AlgTyConFlav - -> TyCon -mkSumTyCon name binders res_kind arity tyvars cons parent - = let tc = - AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = mkSumTyConRhs cons, - algTcFields = emptyDFsEnv, - algTcFlavour = parent - } - in tc - --- | Makes a tycon suitable for use during type-checking. It stores --- a variety of details about the definition of the TyCon, but no --- right-hand side. It lives only during the type-checking of a --- mutually-recursive group of tycons; it is then zonked to a proper --- TyCon in zonkTcTyCon. --- See also Note [Kind checking recursive type and class declarations] --- in "GHC.Tc.TyCl". -mkTcTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ /result/ kind only - -> [(Name,TcTyVar)] -- ^ Scoped type variables; - -- see Note [How TcTyCons work] in GHC.Tc.TyCl - -> Bool -- ^ Is this TcTyCon generalised already? - -> TyConFlavour -- ^ What sort of 'TyCon' this represents - -> TyCon -mkTcTyCon name binders res_kind scoped_tvs poly flav - = let tc = - TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConNullaryTy = mkNakedTyConTy tc - , tcTyConScopedTyVars = scoped_tvs - , tcTyConIsPoly = poly - , tcTyConFlavour = flav } - in tc - --- | No scoped type variables (to be used with mkTcTyCon). -noTcTyConScopedTyVars :: [(Name, TcTyVar)] -noTcTyConScopedTyVars = [] - --- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@ --- Primitive TyCons are marshalable iff not lifted. --- If you'd like to change this, modify marshalablePrimTyCon. -mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). - -- (If you need a representation-polymorphic PrimTyCon, - -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) - -> [Role] - -> TyCon -mkPrimTyCon name binders res_kind roles - = let tc = - PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = roles, - primRepName = mkPrelTyConRepName name - } - in tc - --- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful - = let tc = - SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free, - synIsForgetful = is_forgetful - } - in tc - --- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind resVar flav parent inj - = let tc = - FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConNullaryTy = mkNakedTyConTy tc - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = classTyCon <$> parent - , famTcInj = inj - } - in tc - - --- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- 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 -mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = let tc = - PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = 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 -isAbstractTyCon _ = False - --- | Does this 'TyCon' represent something that cannot be defined in Haskell? -isPrimTyCon :: TyCon -> Bool -isPrimTyCon (PrimTyCon {}) = True -isPrimTyCon _ = False - --- | Returns @True@ if the supplied 'TyCon' resulted from either a --- @data@ or @newtype@ declaration -isAlgTyCon :: TyCon -> Bool -isAlgTyCon (AlgTyCon {}) = True -isAlgTyCon _ = False - --- | Returns @True@ for vanilla AlgTyCons -- that is, those created --- with a @data@ or @newtype@ declaration. -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 --- @case@ expressions, and they get info tables allocated for them. --- --- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples, unboxed sums and type family --- 'TyCon's. But it is not guaranteed to return @True@ in all cases --- that it could. --- --- NB: for a data type family, only the /instance/ 'TyCon's --- get an info table. The family declaration 'TyCon' does not -isDataTyCon (AlgTyCon {algTcRhs = rhs}) - = case rhs of - TupleTyCon { tup_sort = sort } - -> isBoxed (tupleSortBoxity sort) - SumTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False - --- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) --- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) --- 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 -isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True -isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj -isInjectiveTyCon (FamilyTyCon {}) _ = False -isInjectiveTyCon (PrimTyCon {}) _ = True -isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (TcTyCon {}) _ = True - -- Reply True for TcTyCon to minimise knock on type errors - -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl - --- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T tys ~X t), then (t's head ~X T). --- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" -isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True -isGenerativeTyCon (FamilyTyCon {}) _ = False - -- in all other cases, injectivity implies generativity -isGenerativeTyCon tc r = isInjectiveTyCon tc r - --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective --- with respect to representational equality? -isGenInjAlgRhs :: AlgTyConRhs -> Bool -isGenInjAlgRhs (TupleTyCon {}) = True -isGenInjAlgRhs (SumTyCon {}) = True -isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (AbstractTyCon {}) = False -isGenInjAlgRhs (NewTyCon {}) = False - --- | Is this 'TyCon' that for a @newtype@ -isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon _ = False - --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it --- expands into, and (possibly) a coercion from the representation type to the --- @newtype@. --- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) -unwrapNewTyCon_maybe _ = Nothing - -unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, - nt_etad_rhs = (tvs,rhs) }}) - = Just (tvs, rhs, co) -unwrapNewTyConEtad_maybe _ = Nothing - --- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? -{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type -isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynonymTyCon {}) = True -isTypeSynonymTyCon _ = False - -isTauTyCon :: TyCon -> Bool -isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau -isTauTyCon _ = True - --- | Is this tycon neither a type family nor a synonym that expands --- to a type family? -isFamFreeTyCon :: TyCon -> Bool -isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free -isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isFamFreeTyCon _ = True - --- | Is this a forgetful type synonym? If this is a type synonym whose --- RHS does not mention one (or more) of its bound variables, returns --- True. Thus, False means that all bound variables appear on the RHS; --- True may not mean anything, as the test to set this flag is --- conservative. -isForgetfulSynTyCon :: TyCon -> Bool -isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget -isForgetfulSynTyCon _ = False - --- As for newtypes, it is in some contexts important to distinguish between --- closed synonyms and synonym families, as synonym families have no unique --- right hand side to which a synonym family application can expand. --- - --- | True iff we can decompose (T a b c) into ((T a b) c) --- I.e. is it injective and generative w.r.t nominal equality? --- That is, if (T a b) ~N d e f, is it always the case that --- (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 --- type synonym, because you should probably have expanded it first --- But regardless, it's not decomposable -mustBeSaturated :: TyCon -> Bool -mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour - --- | Is this an algebraic 'TyCon' declared with the GADT syntax? -isGadtSyntaxTyCon :: TyCon -> Bool -isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res -isGadtSyntaxTyCon _ = False - --- | Is this an algebraic 'TyCon' which is just an enumeration of values? -isEnumerationTyCon :: TyCon -> Bool --- See Note [Enumeration types] in GHC.Core.TyCon -isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) - = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False -isEnumerationTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family? -isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family with --- instances? -isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) - | OpenSynFamilyTyCon <- flav = True - | DataFamilyTyCon {} <- flav = True -isOpenFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) -isTypeFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isDataFamilyTyCon _ = False - --- | Is this an open type family TyCon? -isOpenTypeFamilyTyCon :: TyCon -> Bool -isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenTypeFamilyTyCon _ = False - --- | Is this a non-empty closed type family? Returns 'Nothing' for --- abstract or empty closed families. -isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) -isClosedSynFamilyTyConWithAxiom_maybe - (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb -isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing - --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an --- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is --- injective), or 'NotInjective' otherwise. -tyConInjectivityInfo :: TyCon -> Injectivity -tyConInjectivityInfo tc - | FamilyTyCon { famTcInj = inj } <- tc - = inj - | isInjectiveTyCon tc Nominal - = Injective (replicate (tyConArity tc) True) - | otherwise - = NotInjective - -isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily -isBuiltInSynFamTyCon_maybe - (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing - -isDataFamFlav :: FamTyConFlav -> Bool -isDataFamFlav (DataFamilyTyCon {}) = True -- Data family -isDataFamFlav _ = False -- Type synonym family - --- | Is this TyCon for an associated type? -isTyConAssoc :: TyCon -> Bool -isTyConAssoc = isJust . tyConAssoc_maybe - --- | Get the enclosing class TyCon (if there is one) for the given TyCon. -tyConAssoc_maybe :: TyCon -> Maybe TyCon -tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour - --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour -tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon -tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe _ = Nothing - --- The unit tycon didn't used to be classed as a tuple tycon --- but I thought that was silly so I've undone it --- If it can't be for some reason, it should be a AlgTyCon -isTupleTyCon :: TyCon -> Bool --- ^ Does this 'TyCon' represent a tuple? --- --- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to --- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they --- get spat into the interface file as tuple tycons, so I don't think --- it matters. -isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isTupleTyCon _ = False - -tyConTuple_maybe :: TyCon -> Maybe TupleSort -tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort} <- rhs = Just sort -tyConTuple_maybe _ = Nothing - --- | Is this the 'TyCon' for an unboxed tuple? -isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnboxedTupleTyCon _ = False - --- | Is this the 'TyCon' for a boxed tuple? -isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = isBoxed (tupleSortBoxity sort) -isBoxedTupleTyCon _ = False - --- | Is this the 'TyCon' for an unboxed sum? -isUnboxedSumTyCon :: TyCon -> Bool -isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) - | SumTyCon {} <- rhs - = True -isUnboxedSumTyCon _ = False - -isLiftedAlgTyCon :: TyCon -> Bool -isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind }) - = isLiftedTypeKind res_kind -isLiftedAlgTyCon _ = False - --- | Is this the 'TyCon' for a /promoted/ tuple? -isPromotedTupleTyCon :: TyCon -> Bool -isPromotedTupleTyCon tyCon - | Just dataCon <- isPromotedDataCon_maybe tyCon - , isTupleTyCon (dataConTyCon dataCon) = True - | otherwise = False - --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing - --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? -isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys - --- | These TyCons should be allowed at the kind level, even without --- -XDataKinds. -kindTyConKeys :: UniqSet Unique -kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon - , multiplicityTyCon - , vecCountTyCon, vecElemTyCon ] ) - where - tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) - -isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) - --- | Identifies implicit tycons that, in particular, do not go into interface --- files (because they are implicitly reconstructed when the interface is --- read). --- --- Note that: --- --- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and --- --- * Family instances are /not/ implicit as they represent the instance body --- (similar to a @dfun@ does that for a class instance). --- --- * Tuples are implicit iff they have a wired-in name --- (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 }) - | TupleTyCon {} <- rhs = isWiredInName name - | SumTyCon {} <- rhs = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent -isImplicitTyCon (SynonymTyCon {}) = False -isImplicitTyCon (TcTyCon {}) = False - -tyConCType_maybe :: TyCon -> Maybe CType -tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc -tyConCType_maybe _ = Nothing - --- | Is this a TcTyCon? (That is, one only used during type-checking?) -isTcTyCon :: TyCon -> Bool -isTcTyCon (TcTyCon {}) = True -isTcTyCon _ = False - -setTcTyConKind :: TyCon -> Kind -> TyCon --- Update the Kind of a TcTyCon --- The new kind is always a zonked version of its previous --- kind, so we don't need to update any other fields. --- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType -setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind - , tyConNullaryTy = mkNakedTyConTy tc' - -- see Note [Sharing nullary TyCons] - } - in tc' -setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) - --- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied, --- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? --- --- False is safe. True means we're sure. --- Does only a quick check, based on the TyCon's category. --- --- 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. - -- Note that this is an entirely different matter from the concreteness - -- of the 'TyCon', in the sense of 'isConcreteTyCon'. - - DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev - -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423). - -- NB: the current representation-polymorphism checks require that - -- the representation be fully-known, including levity variables. - -- This might be relaxed in the future (#15532). - - TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) - - SumTyCon {} -> False -- only unboxed sums here - - NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep - -- A newtype might not have a fixed runtime representation - -- with UnliftedNewtypes (#17360) - -tcHasFixedRuntimeRep SynonymTyCon{} = False -- conservative choice -tcHasFixedRuntimeRep FamilyTyCon{} = False -tcHasFixedRuntimeRep PrimTyCon{} = True -tcHasFixedRuntimeRep TcTyCon{} = False -tcHasFixedRuntimeRep tc@PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) - --- | Is this 'TyCon' concrete (i.e. not a synonym/type family)? --- --- Used for representation polymorphism checks. -isConcreteTyCon :: TyCon -> Bool -isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour - --- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)? --- --- Used for representation polymorphism checks. -isConcreteTyConFlavour :: TyConFlavour -> Bool -isConcreteTyConFlavour = \case - ClassFlavour -> True - TupleFlavour {} -> True - SumFlavour -> True - DataTypeFlavour -> True - NewtypeFlavour -> True - AbstractTypeFlavour -> True -- See Note [Concrete types] in GHC.Tc.Utils.Concrete - DataFamilyFlavour {} -> False - OpenTypeFamilyFlavour {} -> False - ClosedTypeFamilyFlavour -> False - TypeSynonymFlavour -> False - BuiltInTypeFlavour -> True - PromotedDataConFlavour -> True - -{- ------------------------------------------------ --- Expand type-constructor applications ------------------------------------------------ --} - -expandSynTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body - -- type of the synonym (not yet substituted) - -- and any arguments remaining from the - -- application --- ^ Expand a type synonym application --- Return Nothing if the TyCon is not a synonym, --- or if not enough arguments are supplied -expandSynTyCon_maybe tc tys - | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = if arity == 0 - then Just ([], rhs, tys) -- Avoid a bit of work in the case of nullary synonyms - else case tys `listLengthCmp` arity of - GT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - LT -> Nothing - | otherwise - = Nothing - ----------------- - --- | Check if the tycon actually refers to a proper `data` or `newtype` --- with user defined constructors rather than one from a class or other --- construction. - --- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an --- exported tycon can have a pattern synonym bundled with it, e.g., --- module Foo (TyCon(.., PatSyn)) where -isTyConWithSrcDataCons :: TyCon -> Bool -isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcFlavour = parent }) = - case rhs of - DataTyCon {} -> isSrcParent - NewTyCon {} -> isSrcParent - TupleTyCon {} -> isSrcParent - _ -> False - where - isSrcParent = isNoParent parent -isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) - = True -- #14058 -isTyConWithSrcDataCons _ = False - - --- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no --- constructors could be found -tyConDataCons :: TyCon -> [DataCon] --- It's convenient for tyConDataCons to return the --- empty list for type synonyms etc -tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] - --- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' --- is the sort that can have any constructors (note: this does not include --- abstract algebraic types) -tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) - = case rhs of - DataTyCon { data_cons = cons } -> Just cons - NewTyCon { data_con = con } -> Just [con] - TupleTyCon { data_con = con } -> Just [con] - SumTyCon { data_cons = cons } -> Just cons - _ -> Nothing -tyConDataCons_maybe _ = Nothing - --- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ --- type with one alternative, a tuple type or a @newtype@ then that constructor --- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. -tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleDataCon_maybe _ = Nothing - --- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. -tyConSingleDataCon :: TyCon -> DataCon -tyConSingleDataCon tc - = case tyConSingleDataCon_maybe tc of - Just c -> c - Nothing -> pprPanic "tyConDataCon" (ppr tc) - --- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. -tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleAlgDataCon_maybe tycon - | isNewTyCon tycon = Nothing - | otherwise = tyConSingleDataCon_maybe tycon - --- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type --- or a sum type with data constructors dcs. If the 'TyCon' has more than one --- constructor, or represents a primitive or function type constructor then --- @Nothing@ is returned. --- --- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes. -tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConAlgDataCons_maybe tycon - | isNewTyCon tycon = Nothing - | otherwise = tyConDataCons_maybe tycon - --- | Determine the number of value constructors a 'TyCon' has. Panics if the --- 'TyCon' is not algebraic or a tuple -tyConFamilySize :: TyCon -> Int -tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons_size = size } -> size - NewTyCon {} -> 1 - TupleTyCon {} -> 1 - SumTyCon { data_cons_size = size } -> size - _ -> pprPanic "tyConFamilySize 1" (ppr tc) -tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) - --- | Extract an 'AlgTyConRhs' with information about data constructors from an --- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs other = pprPanic "algTyConRhs" (ppr other) - --- | Extract type variable naming the result of injective type family -tyConFamilyResVar_maybe :: TyCon -> Maybe Name -tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res -tyConFamilyResVar_maybe _ = Nothing - --- | Get the list of roles for the type parameters of a TyCon -tyConRoles :: TyCon -> [Role] --- See also Note [TyCon Role signatures] -tyConRoles tc - = case tc of - { FunTyCon {} -> [Nominal, Nominal, Nominal, Representational, Representational] - ; AlgTyCon { tcRoles = roles } -> roles - ; SynonymTyCon { tcRoles = roles } -> roles - ; FamilyTyCon {} -> const_role Nominal - ; PrimTyCon { tcRoles = roles } -> roles - ; PromotedDataCon { tcRoles = roles } -> roles - ; TcTyCon {} -> const_role Nominal - } - where - const_role r = replicate (tyConArity tc) r - --- | Extract the bound type variables and type expansion of a type synonym --- 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) - = (tvs, rhs) -newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) - --- | The number of type parameters that need to be passed to a newtype to --- resolve it. May be less than in the definition if it can be eta-contracted. -newTyConEtadArity :: TyCon -> Int -newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) - = length (fst tvs_rhs) -newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) - --- | Extract the bound type variables and type expansion of an eta-contracted --- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConEtadRhs :: TyCon -> ([TyVar], Type) -newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs -newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) - --- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to --- construct something with the @newtype@s type from its representation type --- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns --- @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing - -newTyConCo :: TyCon -> CoAxiom Unbranched -newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co - Nothing -> pprPanic "newTyConCo" (ppr tc) - -newTyConDataCon_maybe :: TyCon -> Maybe DataCon -newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con -newTyConDataCon_maybe _ = Nothing - --- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context --- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration --- @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 tycon = pprPanic "tyConStupidTheta" (ppr tycon) - --- | Extract the 'TyVar's bound by a vanilla type synonym --- and the corresponding (unsubstituted) right hand side. -synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) - = Just (tyvars, ty) -synTyConDefn_maybe _ = Nothing - --- | Extract the information pertaining to the right hand side of a type synonym --- (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe Type -synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing - --- | Extract the flavour of a type family (with all the extra information that --- it carries) -famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav -famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav -famTyConFlav_maybe _ = Nothing - --- | Is this 'TyCon' that for a class instance? -isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcFlavour = ClassTyCon {}}) = True -isClassTyCon _ = False - --- | If this 'TyCon' is that for a class instance, return the class it is for. --- Otherwise returns @Nothing@ -tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = Just clas -tyConClass_maybe _ = Nothing - --- | Return the associated types of the 'TyCon', if any -tyConATs :: TyCon -> [TyCon] -tyConATs (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = classATs clas -tyConATs _ = [] - ----------------------------------------------------------------------------- --- | Is this 'TyCon' that for a data family instance? -isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcFlavour = DataFamInstTyCon {} }) - = True -isFamInstTyCon _ = False - -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts }) - = Just (f, ts, ax) -tyConFamInstSig_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return the family in question --- and the instance types. Otherwise, return @Nothing@ -tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts }) - = Just (f, ts) -tyConFamInst_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which --- represents a coercion identifying the representation type with the type --- instance family. Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ }) - = Just ax -tyConFamilyCoercion_maybe _ = Nothing - --- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI - -- could panic in that second case. But Douglas Adams told me not to. - -{- -Note [Constructor tag allocation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking we need to allocate constructor tags to constructors. -They are allocated based on the position in the data_cons field of TyCon, -with the first constructor getting fIRST_TAG. - -We used to pay linear cost per constructor, with each constructor looking up -its relative index in the constructor list. That was quadratic and prohibitive -for large data types with more than 10k constructors. - -The current strategy is to build a NameEnv with a mapping from constructor's -Name to ConTag and pass it down to buildDataCon for efficient lookup. - -Relevant ticket: #14657 --} - -mkTyConTagMap :: TyCon -> NameEnv ConTag -mkTyConTagMap tycon = - mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] - -- See Note [Constructor tag allocation] - -{- -************************************************************************ -* * -\subsection[TyCon-instances]{Instance declarations for @TyCon@} -* * -************************************************************************ - -@TyCon@s are compared by comparing their @Unique@s. --} - -instance Eq TyCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable TyCon where - getUnique tc = tyConUnique tc - -instance Outputable TyCon where - -- At the moment a promoted TyCon has the same Name as its - -- corresponding TyCon, so we add the quote to distinguish it here - ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc - where - pp_tc = getPprStyle $ \sty -> - getPprDebug $ \debug -> - if ((debug || dumpStyle sty) && isTcTyCon tc) - then text "[tc]" - else empty - --- | Paints a picture of what a 'TyCon' represents, in broad strokes. --- This is used towards more informative error messages. -data TyConFlavour - = ClassFlavour - | TupleFlavour Boxity - | SumFlavour - | DataTypeFlavour - | NewtypeFlavour - | AbstractTypeFlavour - | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | ClosedTypeFamilyFlavour - | TypeSynonymFlavour - | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. - | PromotedDataConFlavour - deriving Eq - -instance Outputable TyConFlavour where - ppr = text . go - where - go ClassFlavour = "class" - go (TupleFlavour boxed) | isBoxed boxed = "tuple" - | otherwise = "unboxed tuple" - go SumFlavour = "unboxed sum" - go DataTypeFlavour = "data type" - go NewtypeFlavour = "newtype" - go AbstractTypeFlavour = "abstract type" - go (DataFamilyFlavour (Just _)) = "associated data family" - go (DataFamilyFlavour Nothing) = "data family" - go (OpenTypeFamilyFlavour (Just _)) = "associated type family" - go (OpenTypeFamilyFlavour Nothing) = "type family" - go ClosedTypeFamilyFlavour = "type family" - go TypeSynonymFlavour = "type synonym" - go BuiltInTypeFlavour = "built-in type" - go PromotedDataConFlavour = "promoted data constructor" - -tyConFlavour :: TyCon -> TyConFlavour -tyConFlavour (AlgTyCon { algTcFlavour = parent, algTcRhs = rhs }) - | ClassTyCon _ _ <- parent = ClassFlavour - | otherwise = case rhs of - TupleTyCon { tup_sort = sort } - -> TupleFlavour (tupleSortBoxity sort) - SumTyCon {} -> SumFlavour - DataTyCon {} -> DataTypeFlavour - NewTyCon {} -> NewtypeFlavour - AbstractTyCon {} -> AbstractTypeFlavour -tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) - = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent - ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour - AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour - BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour -tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour -tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour -tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav - --- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> Bool -tcFlavourMustBeSaturated ClassFlavour = False -tcFlavourMustBeSaturated DataTypeFlavour = False -tcFlavourMustBeSaturated NewtypeFlavour = False -tcFlavourMustBeSaturated DataFamilyFlavour{} = False -tcFlavourMustBeSaturated TupleFlavour{} = False -tcFlavourMustBeSaturated SumFlavour = False -tcFlavourMustBeSaturated AbstractTypeFlavour {} = False -tcFlavourMustBeSaturated BuiltInTypeFlavour = False -tcFlavourMustBeSaturated PromotedDataConFlavour = False -tcFlavourMustBeSaturated TypeSynonymFlavour = True -tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True -tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True - --- | Is this flavour of 'TyCon' an open type family or a data family? -tcFlavourIsOpen :: TyConFlavour -> Bool -tcFlavourIsOpen DataFamilyFlavour{} = True -tcFlavourIsOpen OpenTypeFamilyFlavour{} = True -tcFlavourIsOpen ClosedTypeFamilyFlavour = False -tcFlavourIsOpen ClassFlavour = False -tcFlavourIsOpen DataTypeFlavour = False -tcFlavourIsOpen NewtypeFlavour = False -tcFlavourIsOpen TupleFlavour{} = False -tcFlavourIsOpen SumFlavour = False -tcFlavourIsOpen AbstractTypeFlavour {} = False -tcFlavourIsOpen BuiltInTypeFlavour = False -tcFlavourIsOpen PromotedDataConFlavour = False -tcFlavourIsOpen TypeSynonymFlavour = False - -pprPromotionQuote :: TyCon -> SDoc --- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - = case tc of - PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - _ -> empty + PromDataConInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConPiTyBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder, + tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkLevPolyDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, + isClassTyCon, isFamInstTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isLiftedAlgTyCon, + isTypeSynonymTyCon, + tyConMustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isDataKindsPromotedDataCon, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, + + isDataTyCon, + isTypeDataTyCon, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + tcHasFixedRuntimeRep, + isConcreteTyCon, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConAlgDataCons_maybe, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConNullaryTy, mkTyConTy, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConPromDataConInfo, + tyConBinders, tyConResKind, tyConInvisTVBinders, + tcTyConScopedTyVars, isMonoTcTyCon, + tyConHasClosedResKind, + mkTyConTagMap, + + -- ** Manipulating TyCons + ExpandSynResult(..), + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + primElemRepToPrimRep, + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + primRepIsWord, + primRepIsInt, + +) where + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy ) +import {-# SOURCE #-} GHC.Core.TyCo.FVs + ( noFreeVarsOfType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTyCon, constraintKind, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumDataCon, isTypeDataCon ) +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) +import GHC.Builtin.Uniques + ( tyConRepNameUnique + , dataConTyRepNameUnique ) + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Class +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Names +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Data.FastString.Env +import GHC.Types.FieldLabel +import GHC.Settings.Constants +import GHC.Utils.Misc +import GHC.Types.Unique.Set +import GHC.Unit.Module + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as they did with type + synonym families. They just see constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is looked up (via tcLookupDataFamilyInst) + in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to + solve representational equalities like + T Int ~R# Bool + Here we look up (T Int), convert it to R:TInt, and then unwrap the + newtype R:TInt. + + It is also looked up in reduceTyFamApp_maybe. + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in GHC.Tc.Deriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no representation polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in GHC.Hs.Decls + * [Renaming injectivity annotation] in GHC.Rename.Module + * [Verifying injectivity annotation] in GHC.Core.FamInstEnv + * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact + +Note [Sharing nullary TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nullary type constructor applications are extremely common. For this reason +each TyCon carries with it a @TyConApp tycon []@. This ensures that +'mkTyConTy' does not need to allocate and eliminates quite a bit of heap +residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', +ensuring that this function also benefits from sharing. + +This optimisation improves allocations in the Cabal test by around 0.3% and +decreased cache misses measurably. + +See #19367. + + +************************************************************************ +* * + TyConBinder, TyConPiTyBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis +type TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis + -- Only PromotedDataCon has TyConPiTyBinders + -- See Note [Promoted GADT data constructors] + +data TyConBndrVis + = NamedTCB ForAllTyFlag + | AnonTCB FunTyFlag + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = ppr flag + ppr (AnonTCB af) = ppr af + +mkAnonTyConBinder :: TyVar -> TyConBinder +-- Make a visible anonymous TyCon binder +mkAnonTyConBinder tv = assert (isTyVar tv) $ + Bndr tv (AnonTCB visArgTypeLike) + +mkAnonTyConBinders :: [TyVar] -> [TyConBinder] +mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs + +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 :: ForAllTyFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder tv + +tyConBinderForAllTyFlag :: TyConBinder -> ForAllTyFlag +tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis + +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 +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis +isVisibleTcbVis (AnonTCB af) = isVisibleFunArg af + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k + mk (Bndr tv (AnonTCB af)) k = mkNakedFunTy af (varType tv) k + -- mkNakedFunTy: 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 +-- See Note [Building TyVarBinders from TyConBinders] +tyConInvisTVBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB af -- Note [AnonTCB with constraint arg] + | isInvisibleFunArg af -> InferredSpec + | otherwise -> SpecifiedSpec + NamedTCB Required -> SpecifiedSpec + NamedTCB (Invisible vis) -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- 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: + + 'MkT :: forall a b. (a~b) => blah + + 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 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 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 FunTyFlag in +the first place. + +Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +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 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 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', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + +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 ForAllTyBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +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 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/TyConPiTyBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that there are three binders here, including the + kind variable k. + + See Note [tyConBinders and lexical scoping] + +* 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 + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by splitTyConKind + +Note [tyConBinders and lexical scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a TyCon, and a PolyTcTyCon, we obey the following rule: + + The Name of the TyConBinder is precisely + the lexically scoped Name from the original declaration + (precisely = both OccName and Unique) + +For example, + data T a (b :: wombat) = MkT +We will get tyConBinders of [k, wombat, a::k, b::wombat] +The 'k' is made up; the user didn't specify it. But for the kind of 'b' +we must use 'wombat'. + +Why do we have this invariant? + +* Similarly, when typechecking default definitions for class methods, in + GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; + but the variables bound in that class must be in scope. Example (#19738): + + type P :: k -> Type + data P a = MkP + + type T :: k -> Constraint + class T (a :: j) where + f :: P a + f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' + +* When typechecking `deriving` clauses for top-level data declarations, the + tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` + field of GHC.Tc.Deriv.DerivInfo. Example (#16731): + + class C x1 x2 + + type T :: a -> Type + data T (x :: z) deriving (C z) + + When typechecking `C z`, we want `z` to map to `a`, which is exactly what the + tcTyConScopedTyVars for T give us. +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + 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 } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { af <- get bh; return (AnonTCB af) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. +-- +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon = TyCon { + 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 + tyConHasClosedResKind :: Bool, + + -- Cached values + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ + + tyConRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConDetails :: !TyConDetails } + +data TyConDetails = + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- - unboxed sums + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + AlgTyCon { + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + -- See @Note [The stupid context]@ in + -- "GHC.Core.DataCon". + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcFlavour :: AlgTyConFlav -- ^ The flavour of this algebraic tycon. + -- Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + -- tyConTyVars scope over: synTcRhs + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + synIsForgetful :: Bool -- True <= at least one argument is not mentioned + -- in the RHS (or is mentioned only under + -- forgetful synonyms) + -- Test is conservative, so True does not guarantee + -- forgetfulness. + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + primRepName :: TyConRepName -- ^ The 'Typeable' representation. + -- A cached version of + -- @'mkPrelTyConRepName' ('tyConName' tc)@. + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcInfo :: PromDataConInfo -- ^ See comments with 'PromDataConInfo' + } + + -- | These exist only during type-checking. See Note [How TcTyCons work] + -- in "GHC.Tc.TyCl" + | TcTyCon { + -- NB: the tyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tctc_scoped_tvs :: [(Name,TcTyVar)], + -- ^ Scoped tyvars over the tycon's body + -- The range is always a skolem or TcTyVar, be + -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] + + tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized? + -- Used only to make zonking more efficient + + tctc_flavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } + +{- Note [Scoped tyvars in a TcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyVars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons. +See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType. + +Note [Promoted GADT data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Any promoted GADT data constructor will have a type with equality +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 [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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To check for representation-polymorphism directly in the typechecker, +e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep, +we need to compute whether a type has a syntactically fixed RuntimeRep, +as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +It's useful to have a quick way to check whether a saturated application +of a type constructor has a fixed RuntimeRep. That is, we want +to know, given a TyCon 'T' of arity 'n', does + + T a_1 ... a_n + +always have a fixed RuntimeRep? That is, is it always the case +that this application has a kind of the form + + T a_1 ... a_n :: TYPE rep + +in which 'rep' is a concrete 'RuntimeRep'? +('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete: +it contains no type-family applications or type variables.) + +To answer this question, we have 'tcHasFixedRuntimeRep'. +If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that +every saturated application of `T` has a fixed RuntimeRep. +However, if it returns 'False', we don't know: perhaps some application might not +have a fixed RuntimeRep. + +Examples: + + - For type families, we won't know in general whether an application + will have a fixed RuntimeRep: + + type F :: k -> k + type family F a where {..} + + `tcHasFixedRuntimeRep F = False' + + - For newtypes, we're usually OK: + + newtype N a b c = MkN Int + + No matter what arguments we apply `N` to, we always get something of + kind `Type`, which has a fixed RuntimeRep. + Thus `tcHasFixedRuntimeRep N = True`. + + However, with `-XUnliftedNewtypes`, we can have representation-polymorphic + newtypes: + + type UN :: TYPE rep -> TYPE rep + newtype UN a = MkUN a + + `tcHasFixedRuntimeRep UN = False` + + For example, `UN @Int8Rep Int8#` is represented by an 8-bit value, + while `UN @LiftedRep Int` is represented by a heap pointer. + + To distinguish whether we are dealing with a representation-polymorphic newtype, + we keep track of which situation we are in using the 'nt_fixed_rep' + field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field + to compute 'tcHasFixedRuntimeRep'. + + - A similar story can be told for datatypes: we're usually OK, + except with `-XUnliftedDatatypes` which allows for levity polymorphism, + e.g.: + + type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l) + type UC a = MkUC a + + `tcHasFixedRuntimeRep UC = False` + + Here, we keep track of whether we are dealing with a levity-polymorphic + unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon' + constructor of 'AlgTyConRhs'. + + N.B.: technically, the representation of a datatype is fixed, + as it is always a pointer. However, we currently require that we + know the specific `RuntimeRep`: knowing that it's `BoxedRep l` + for a type-variable `l` isn't enough. See #15532. +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool, -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + is_type_data :: Bool, + -- from a "type data" declaration + -- See Note [Type data declarations] in GHC.Rename.Module + data_fixed_lev :: Bool + -- ^ 'True' if the data type constructor has + -- a known, fixed levity when fully applied + -- to its arguments, False otherwise. + -- + -- This can only be 'False' with UnliftedDatatypes, + -- e.g. + -- + -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A } + -- + -- This boolean is cached to make it cheaper to check + -- for levity and representation-polymorphism in + -- tcHasFixedRuntimeRep. + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. The axiom witnesses + -- a representational coercion: + -- nt_co :: N ty1 ~R# rep_tys + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_fixed_rep :: Bool + -- ^ 'True' if the newtype has a known, fixed representation + -- when fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'False' with UnliftedNewtypes. + -- + -- Example: + -- + -- > newtype N (a :: TYPE r) = MkN a + -- + -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt) + -- + -- This boolean is cached to make it cheaper to check if a + -- variable binding is representation-polymorphic + -- in tcHasFixedRuntimeRep. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +-- | Create an 'AlgTyConRhs' from the data constructors, +-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`). +mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity + -> Bool -- ^ True if this is a "type data" declaration + -- See Note [Type data declarations] + -- in GHC.Rename.Module + -> [DataCon] + -> AlgTyConRhs +mkLevPolyDataTyConRhs fixed_lev type_data cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons, + -- See Note [Enumeration types] in GHC.Core.TyCon + is_type_data = type_data, + data_fixed_lev = fixed_lev + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Create an 'AlgTyConRhs' from the data constructors. +-- +-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic +-- or if it comes from a "data type" declaration +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' +-- 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. +-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" +data PromDataConInfo + = NoPromInfo -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ 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` + + | 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 +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- | Describes the flavour of an algebraic type constructor. For +-- classes and data families, this flavour includes a reference to +-- the parent 'TyCon'. +data AlgTyConFlav + = -- | An ordinary algebraic type constructor. This includes unlifted and + -- representation-polymorphic datatypes and newtypes and unboxed tuples, + -- but NOT unboxed sums; see UnboxedSumTyCon. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon + -- because we currently don't allow unboxed sums to be Typeable since + -- there are too many of them. See #13276. + | UnboxedSumTyCon + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see + -- Note [Eta reduction for data families] in + -- GHC.Core.Coercion.Axiom + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedSumTyCon {}) = text "Unboxed sum" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedSumTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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) + 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) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. + +We might also eta-contract the axiom: see Note [Newtype eta]. + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal? That is, does a coercion exist between them? + Monad Parser + Monad IO +(We need this coercion to make the derived instance for Monad Parser.) + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to IO, so that even unsaturated applications of +Parser will work right. So instead of + axParser :: forall a. Parser a ~ IO a +we generate an eta-reduced axiom + axParser :: Parser ~ IO + +This eta reduction is done when the type constructor is built, in +GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon. + +Here's an example that I think showed up in practice. +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we would like to get: + w2 = w1 `cast` Foo axT + +so that w2 and w1 share the same code. To do this, the coercion axiom +axT must have + kind: axT :: T ~ [] + and arity: 0 + +See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details + where + get_rep_nm (PrimTyCon { primRepName = rep_nm }) + = Just rep_nm + get_rep_nm (AlgTyCon { algTcFlavour = parent }) + = case parent of + VanillaAlgTyCon rep_nm -> Just rep_nm + UnboxedSumTyCon -> Nothing + ClassTyCon _ rep_nm -> Just rep_nm + DataFamInstTyCon {} -> Nothing + get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm + get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumDataCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm + get_rep_nm _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] +~~~~~~~~~~~~~~~~ +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width ("GHC.Cmm.Type") is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in +-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". +data PrimRep + = VoidRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value + | Word64Rep -- ^ Unsigned, 64 bit value + | WordRep -- ^ Unsigned, word-sized value + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Data.Data, Eq, Ord, Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Data.Data, Eq, Ord, Show, Enum ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +instance Binary PrimRep where + put_ bh VoidRep = putByte bh 0 + put_ bh LiftedRep = putByte bh 1 + put_ bh UnliftedRep = putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per + get bh = do + h <- getByte bh + case h of + 0 -> pure VoidRep + 1 -> pure LiftedRep + 2 -> pure UnliftedRep + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh + _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) + +instance Binary PrimElemRep where + put_ bh per = putByte bh (fromIntegral (fromEnum per)) + get bh = toEnum . fromIntegral <$> getByte bh + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +isGcPtrRep _ = False + +-- A PrimRep is compatible with another iff one can be coerced to the other. +-- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. +primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = + (isUnboxed rep1 == isUnboxed rep2) && + (primRepSizeB platform rep1 == primRepSizeB platform rep2) && + (primRepIsFloat rep1 == primRepIsFloat rep2) + where + isUnboxed = not . isGcPtrRep + +-- More general version of `primRepCompatible` for types represented by zero or +-- more than one PrimReps. +primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible platform) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- laid out. +primRepSizeB :: Platform -> PrimRep -> Int +primRepSizeB platform = \case + IntRep -> platformWordSizeInBytes platform + WordRep -> platformWordSizeInBytes platform + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> 8 + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> 8 + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> platformWordSizeInBytes platform + LiftedRep -> platformWordSizeInBytes platform + UnliftedRep -> platformWordSizeInBytes platform + VoidRep -> 0 + (VecRep len rep) -> len * primElemRepSizeB platform rep + +primElemRepSizeB :: Platform -> PrimElemRep -> Int +primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep + +primElemRepToPrimRep :: PrimElemRep -> PrimRep +primElemRepToPrimRep Int8ElemRep = Int8Rep +primElemRepToPrimRep Int16ElemRep = Int16Rep +primElemRepToPrimRep Int32ElemRep = Int32Rep +primElemRepToPrimRep Int64ElemRep = Int64Rep +primElemRepToPrimRep Word8ElemRep = Word8Rep +primElemRepToPrimRep Word16ElemRep = Word16Rep +primElemRepToPrimRep Word32ElemRep = Word32Rep +primElemRepToPrimRep Word64ElemRep = Word64Rep +primElemRepToPrimRep FloatElemRep = FloatRep +primElemRepToPrimRep DoubleElemRep = DoubleRep + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + +-- Rep is one of the word reps. +primRepIsWord :: PrimRep -> Bool +primRepIsWord WordRep = True +primRepIsWord (Word8Rep) = True +primRepIsWord (Word16Rep) = True +primRepIsWord (Word32Rep) = True +primRepIsWord (Word64Rep) = True +primRepIsWord _ = False + +-- Rep is one of the int reps. +primRepIsInt :: PrimRep -> Bool +primRepIsInt (IntRep) = True +primRepIsInt (Int8Rep) = True +primRepIsInt (Int16Rep) = True +primRepIsInt (Int32Rep) = True +primRepIsInt (Int64Rep) = True +primRepIsInt _ = False + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFields = fields } <- details = fields + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl) + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon +mkTyCon name binders res_kind roles details + = tc + where + -- Recurisve binding because of tcNullaryTy + tc = TyCon { tyConName = name + , tyConUnique = nameUnique name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConRoles = roles + , tyConDetails = details + + -- Cached things + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConNullaryTy = mkNakedTyConTy tc + , tyConHasClosedResKind = noFreeVarsOfType res_kind + , tyConTyVars = binderVars binders } + +-- | This is the making of an algebraic 'TyCon'. +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = mkTyCon name binders res_kind roles $ + AlgTyCon { tyConCType = cType + , algTcStupidTheta = stupid + , algTcRhs = rhs + , algTcFields = fieldsOfAlgTcRhs rhs + , algTcFlavour = assertPpr (okParent name parent) + (ppr name $$ ppr parent) parent + , algTcGadtSyntax = gadt_syn } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind con sort parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = TupleTyCon { data_con = con + , tup_sort = sort } + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +constRoles :: [TyConBinder] -> Role -> [Role] +constRoles bndrs role = [role | _ <- bndrs] + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind cons parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = mkSumTyConRhs cons + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See also Note [Kind checking recursive type and class declarations] +-- in "GHC.Tc.TyCl". +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -- see Note [How TcTyCons work] in GHC.Tc.TyCl + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + TcTyCon { tctc_scoped_tvs = scoped_tvs + , tctc_is_poly = poly + , tctc_flavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@ +-- Primitive TyCons are marshalable iff not lifted. +-- If you'd like to change this, modify marshalablePrimTyCon. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). + -- (If you need a representation-polymorphic PrimTyCon, + -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) + -> [Role] + -> TyCon +mkPrimTyCon name binders res_kind roles + = mkTyCon name binders res_kind roles $ + PrimTyCon { primRepName = mkPrelTyConRepName name } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful + = mkTyCon name binders res_kind roles $ + SynonymTyCon { synTcRhs = rhs + , synIsTau = is_tau + , synIsFamFree = is_fam_free + , synIsForgetful = is_forgetful } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + FamilyTyCon { famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj } + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConPiTyBinder] -> Kind -> [Role] + -> PromDataConInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = mkTyCon name binders res_kind roles $ + PromotedDataCon { dataCon = con + , tcRepName = rep_name + , promDcInfo = rep_info } + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True + | otherwise = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (TyCon { tyConDetails = details }) + | PrimTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True + | otherwise = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + -- Constructors from "type data" declarations exist only at + -- the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + DataTyCon { is_type_data = type_data } -> not type_data + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | Was this 'TyCon' declared as "type data"? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataTyCon :: TyCon -> Bool +isTypeDataTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details + = type_data + | otherwise = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where r is the role passed in): +-- If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2) +-- (where r1, r2, and r3, are the roles given by tyConRolesX tc r) +-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical" +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon (TyCon { tyConDetails = details }) role + = go details role + where + go _ Phantom = True -- Vacuously; (t1 ~P t2) holds for all t1, t2! + go (AlgTyCon {}) Nominal = True + go (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs + go (SynonymTyCon {}) _ = False + go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True + go (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj + go (FamilyTyCon {}) _ = False + go (PrimTyCon {}) _ = True + go (PromotedDataCon {}) _ = True + go (TcTyCon {}) _ = True + + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl + + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where r is the role passed in): +-- If (T tys ~r t), then (t's head ~r T). +-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical" +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role + = go role details + where + go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True + go _ (FamilyTyCon {}) = False + + -- In all other cases, injectivity implies generativity + go r _ = isInjectiveTyCon tc r + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (AbstractTyCon {}) = False +isGenInjAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True + | otherwise = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co + , nt_etad_rhs = (tvs,rhs) }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon {} <- details = True + | otherwise = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsTau = is_tau } <- details = is_tau + | otherwise = True + +-- | Is this tycon neither a type family nor a synonym that expands +-- to a type family? +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = True + +-- | Is this a forgetful type synonym? If this is a type synonym whose +-- RHS does not mention one (or more) of its bound variables, returns +-- True. Thus, False means that all bound variables appear on the RHS; +-- True may not mean anything, as the test to set this flag is +-- conservative. +isForgetfulSynTyCon :: TyCon -> Bool +isForgetfulSynTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsForgetful = forget } <- details = forget + | otherwise = False + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- 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 +tyConMustBeSaturated :: TyCon -> Bool +tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcGadtSyntax = res } <- details = res + | otherwise = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {} <- details = True + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav } <- details + = case flav of + OpenSynFamilyTyCon -> True + DataFamilyTyCon {} -> True + _ -> False + | otherwise = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav) + | otherwise = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True + | otherwise = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb + | otherwise = Nothing + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops } <- details = Just ops + | otherwise = Nothing + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcResVar = res} <- details = res + | otherwise = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc@(TyCon { tyConDetails = details }) + | FamilyTyCon { famTcInj = inj } <- details + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon +tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True + | otherwise = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort} <- rhs = Just sort + | otherwise = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) + | otherwise = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) + | otherwise = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , SumTyCon {} <- rhs + = True + | otherwise = False + +isLiftedAlgTyCon :: TyCon -> Bool +isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details }) + | AlgTyCon {} <- details = isLiftedTypeKind res_kind + | otherwise = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details = Just dc + | otherwise = Nothing + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon {} <- details = True + | otherwise = False + +-- | This function identifies PromotedDataCon's from data constructors in +-- `data T = K1 | K2`, promoted by -XDataKinds. These type constructors +-- are printed with a tick mark 'K1 and 'K2, and similarly have a tick +-- mark added to their OccName's. +-- +-- In contrast, constructors in `type data T = K1 | K2` are printed and +-- represented with their original undecorated names. +-- See Note [Type data declarations] in GHC.Rename.Module +isDataKindsPromotedDataCon :: TyCon -> Bool +isDataKindsPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details + = not (isTypeDataCon dc) + | otherwise = False + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details + where + go (PrimTyCon {}) = True + go (PromotedDataCon {}) = True + go (SynonymTyCon {}) = False + go (TcTyCon {}) = False + go (FamilyTyCon { famTcParent = parent }) = isJust parent + go (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype + | otherwise = Nothing + +-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied, +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? +-- +-- False is safe. True means we're sure. +-- Does only a quick check, based on the TyCon's category. +-- +-- See Note [Representation-polymorphic TyCons] +tcHasFixedRuntimeRep :: TyCon -> Bool +tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + AbstractTyCon {} -> False + -- An abstract TyCon might not have a fixed runtime representation. + -- Note that this is an entirely different matter from the concreteness + -- of the 'TyCon', in the sense of 'isConcreteTyCon'. + + DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev + -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423). + -- NB: the current representation-polymorphism checks require that + -- the representation be fully-known, including levity variables. + -- This might be relaxed in the future (#15532). + + TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) + + SumTyCon {} -> False -- only unboxed sums here + + NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep + -- A newtype might not have a fixed runtime representation + -- with UnliftedNewtypes (#17360) + + | SynonymTyCon {} <- details = False -- conservative choice + | FamilyTyCon{} <- details = False + | PrimTyCon{} <- details = True + | TcTyCon{} <- details = False + | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) + +-- | Is this 'TyCon' concrete (i.e. not a synonym/type family)? +-- +-- Used for representation polymorphism checks. +isConcreteTyCon :: TyCon -> Bool +isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour + +-- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)? +-- +-- Used for representation polymorphism checks. +isConcreteTyConFlavour :: TyConFlavour -> Bool +isConcreteTyConFlavour = \case + ClassFlavour -> True + TupleFlavour {} -> True + SumFlavour -> True + DataTypeFlavour -> True + NewtypeFlavour -> True + AbstractTypeFlavour -> True -- See Note [Concrete types] in GHC.Tc.Utils.Concrete + DataFamilyFlavour {} -> False + OpenTypeFamilyFlavour {} -> False + ClosedTypeFamilyFlavour -> False + TypeSynonymFlavour -> False + BuiltInTypeFlavour -> True + PromotedDataConFlavour -> True + +{- +----------------------------------------------- +-- TcTyCon +----------------------------------------------- +-} + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon {} <- details = True + | otherwise = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType +setTcTyConKind tc kind + = assert (isMonoTcTyCon tc) $ + let tc' = tc { tyConKind = kind + , tyConNullaryTy = mkNakedTyConTy tc' } + -- See Note [Sharing nullary TyConApps] + in tc' + +isMonoTcTyCon :: TyCon -> Bool +isMonoTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly + | otherwise = False + +tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)] +tcTyConScopedTyVars tc@(TyCon { tyConDetails = details }) + | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs + | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +data ExpandSynResult tyco + = NoExpansion + | ExpandsSyn [(TyVar,tyco)] Type [tyco] + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> ExpandSynResult tyco -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application +-- ^ Expand a type synonym application +-- Return Nothing if the TyCon is not a synonym, +-- or if not enough arguments are supplied +expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity + , tyConDetails = details }) tys + | SynonymTyCon { synTcRhs = rhs } <- details + = if arity == 0 + then ExpandsSyn [] rhs tys -- Avoid a bit of work in the case of nullary synonyms + else case tys `listLengthCmp` arity of + GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys) + EQ -> ExpandsSyn (tvs `zip` tys) rhs [] + LT -> NoExpansion + | otherwise + = NoExpansion + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details + , let isSrcParent = isNoParent parent + = case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details + = True -- #14058 + | otherwise = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + _ -> Nothing + | otherwise = Nothing + +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +-- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleAlgDataCon_maybe tycon + | isNewTyCon tycon = Nothing + | otherwise = tyConSingleDataCon_maybe tycon + +-- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type +-- or a sum type with data constructors dcs. If the 'TyCon' has more than one +-- constructor, or represents a primitive or function type constructor then +-- @Nothing@ is returned. +-- +-- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes. +tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConAlgDataCons_maybe tycon + | isNewTyCon tycon = Nothing + | otherwise = tyConDataCons_maybe tycon + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) + | otherwise = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details = rhs + | otherwise = pprPanic "algTyConRhs" (ppr tc) + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details + = (tvs, rhs) + | otherwise + = pprPanic "newTyConRhs" (ppr tc) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details + = length (fst tvs_rhs) + | otherwise + = pprPanic "newTyConEtadArity" (ppr tc) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs + | otherwise = pprPanic "newTyConEtadRhs" (ppr tc) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co + | otherwise = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con + | otherwise = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid + | PrimTyCon {} <- details = [] + | otherwise = pprPanic "tyConStupidTheta" (ppr tc) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details }) + | SynonymTyCon {synTcRhs = ty} <- details + = Just (tyvars, ty) + | otherwise + = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (TyCon { tyConDetails = details }) + | SynonymTyCon {synTcRhs = rhs} <- details = Just rhs + | otherwise = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav} <- details = Just flav + | otherwise = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True + | otherwise = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas + | otherwise = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas + | otherwise = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True + | otherwise = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax + | otherwise = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConPromDataConInfo :: TyCon -> PromDataConInfo +tyConPromDataConInfo (TyCon { tyConDetails = details }) + | PromotedDataCon { promDcInfo = rri } <- details = rri + | otherwise = NoPromInfo + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if ((debug || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving Eq + +instance Outputable TyConFlavour where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (DataFamilyFlavour (Just _)) = "associated data family" + go (DataFamilyFlavour Nothing) = "data family" + go (OpenTypeFamilyFlavour (Just _)) = "associated type family" + go (OpenTypeFamilyFlavour Nothing) = "type family" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details + = case parent of + ClassTyCon {} -> ClassFlavour + _ -> case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour + + | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour + + | SynonymTyCon {} <- details = TypeSynonymFlavour + | PrimTyCon {} <- details = BuiltInTypeFlavour + | PromotedDataCon {} <- details = PromotedDataConFlavour + | TcTyCon { tctc_flavour = flav } <-details = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated DataFamilyFlavour{} = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour {} = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour -> Bool +tcFlavourIsOpen DataFamilyFlavour{} = True +tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour {} = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc = + getPprStyle $ \sty -> + let + name = getOccName tc + ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty instance NamedThing TyCon where getName = tyConName diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot --- a/compiler/GHC/Core/TyCon.hs-boot +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -14,7 +14,6 @@ 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 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -3,3923 +3,3312 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Main functions for manipulating types and type-related things -module GHC.Core.Type ( - -- Note some of this is just re-exports from TyCon.. - - -- * Main data types representing Types - -- $type_classification - - -- $representation_types - Type, ArgFlag(..), AnonArgFlag(..), - Specificity(..), - KindOrType, PredType, ThetaType, FRRType, - Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, - Mult, Scaled, - KnotTied, - - -- ** 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, - - mkFunTy, mkVisFunTy, mkInvisFunTy, - mkVisFunTys, - mkVisFunTyMany, mkInvisFunTyMany, - mkVisFunTysMany, mkInvisFunTysMany, - splitFunTy, splitFunTy_maybe, - splitFunTys, funResultTy, funArgTy, - - mkTyConApp, mkTyConTy, mkTYPEapp, - tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, - tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, - tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - tcRepSplitTyConApp_maybe, - - mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, - mkSpecForAllTy, mkSpecForAllTys, - mkVisForAllTys, mkTyCoInvForAllTy, - mkInfForAllTy, mkInfForAllTys, - splitForAllTyCoVars, splitForAllTyVars, - splitForAllReqTVBinders, splitForAllInvisTVBinders, - splitForAllTyCoVarBinders, - splitForAllTyCoVar_maybe, splitForAllTyCoVar, - splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, - getRuntimeArgTys, - mkTyConBindersPreferAnon, - mkPiTy, mkPiTys, - piResultTy, piResultTys, - applyTysX, dropForAlls, - mkFamilyTyConApp, - buildSynTyCon, - - mkNumLitTy, isNumLitTy, - mkStrLitTy, isStrLitTy, - mkCharLitTy, isCharLitTy, - isLitTy, - - isPredTy, - - getRuntimeRep_maybe, kindRep_maybe, kindRep, - - mkCastTy, mkCoercionTy, splitCastTy_maybe, - - userTypeError_maybe, pprUserTypeErrorTy, - - coAxNthLHS, - stripCoercionTy, - - splitInvisPiTys, splitInvisPiTysN, - invisibleTyBndrCount, - filterOutInvisibleTypes, filterOutInferredTypes, - partitionInvisibleTypes, partitionInvisibles, - tyConArgFlags, appTyArgFlags, - - -- ** Analyzing types - TyCoMapper(..), mapTyCo, mapTyCoX, - TyCoFolder(..), foldTyCo, noView, - - -- (Newtypes) - newTyConInstRhs, - - -- ** Binders - sameVis, - mkTyCoVarBinder, mkTyCoVarBinders, - 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, - - -- ** Predicates on types - isTyVarTy, isFunTy, isCoercionTy, - isCoercionTy_maybe, isForAllTy, - isForAllTy_ty, isForAllTy_co, - isPiTy, isTauTy, isFamFreeTy, - isCoVarType, isAtomicTy, - - isValidJoinPointType, - tyConAppNeedsKindSig, - - -- *** Levity and boxity - typeLevity_maybe, - isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, - isBoxedRuntimeRep, - isLiftedLevity, isUnliftedLevity, - isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, - mightBeLiftedType, mightBeUnliftedType, - isStateType, - isAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, - 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, - isLinearType, - - -- * Main data types representing Kinds - Kind, - - -- ** Finding the kind of a type - typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep, - tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, - tcIsBoxedTypeKind, tcIsRuntimeTypeKind, - - -- ** Common Kind - liftedTypeKind, unliftedTypeKind, - - -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, - - anyFreeVarsOfType, anyFreeVarsOfTypes, - noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, - expandTypeSynonyms, - typeSize, occCheckExpand, - - -- ** Closing over kinds - closeOverKindsDSet, closeOverKindsList, - closeOverKinds, - - -- * Well-scoped lists of variables - 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, - - tyConsOfType, - - -- * Main type substitution data types - TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends - - -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - - mkTCvSubst, zipTvSubst, mkTvSubstPrs, - zipTCvSubst, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinderAndInScope, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - extendTvSubstWithClone, - extendTCvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, - - -- ** Performing substitution on types and kinds - substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, - substThetaUnchecked, substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, - substVarBndr, substVarBndrs, - substTyCoBndr, - cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyTyCoVarBinder, tidyTyCoVarBinders, - - -- * Kinds - isConstraintKindCon, - classifiesTypeWithValues, - isConcrete, isFixedRuntimeRepKind, - ) where - -import GHC.Prelude - -import GHC.Types.Basic - --- We import the representation and primitive functions from GHC.Core.TyCo.Rep. --- Many things are reexported, but not the representation! - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.Tidy -import GHC.Core.TyCo.FVs - --- friends: -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -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 ) -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 - , coercionRKind, coercionType - , isReflexiveCo, seqCo - , topNormaliseNewType_maybe - ) -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) - --- others -import GHC.Utils.Misc -import GHC.Utils.FV -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.Data.Maybe ( orElse, expectJust ) -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) --- import GHC.Utils.Trace - --- $type_classification --- #type_classification# --- --- Types are any, but at least one, of: --- --- [Boxed] Iff its representation is a pointer to an object on the --- GC'd heap. Operationally, heap objects can be entered as --- a means of evaluation. --- --- [Lifted] Iff it has bottom as an element: An instance of a --- lifted type might diverge when evaluated. --- GHC Haskell's unboxed types are unlifted. --- An unboxed, but lifted type is not very useful. --- (Example: A byte-represented type, where evaluating 0xff --- computes the 12345678th collatz number modulo 0xff.) --- Only lifted types may be unified with a type variable. --- --- [Algebraic] Iff it is a type with one or more constructors, whether --- declared with @data@ or @newtype@. --- An algebraic type is one that can be deconstructed --- with a case expression. There are algebraic types that --- are not lifted types, like unlifted data types or --- unboxed tuples. --- --- [Data] Iff it is a type declared with @data@, or a boxed tuple. --- There are also /unlifted/ data types. --- --- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. --- --- [Unlifted] Anything that isn't lifted is considered unlifted. --- --- Currently, all primitive types are unlifted, but that's not necessarily --- the case: for example, @Int@ could be primitive. --- --- Some primitive types are unboxed, such as @Int#@, whereas some are boxed --- but unlifted (such as @ByteArray#@). The only primitive types that we --- classify as algebraic are the unboxed tuples. --- --- Some examples of type classifications that may make this a bit clearer are: --- --- @ --- Type primitive boxed lifted algebraic --- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- (\# a | b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes --- @ - --- $representation_types --- A /source type/ is a type that is a separate type as far as the type checker is --- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. --- --- You don't normally have to worry about this, as the utility functions in --- this module will automatically convert a source into a representation type --- if they are spotted, to the best of its abilities. If you don't want this --- to happen, use the equivalent functions from the "TcType" module. - -{- -************************************************************************ -* * - 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 --- See Note [Inlining coreView]. -{-# INLINE coreView #-} - ------------------------------------------------ - --- | @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 --- Just/Nothing, else you'll increase allocation -expandSynTyConApp_maybe tc arg_tys - | Just (tvs, rhs) <- synTyConDefn_maybe tc - , arg_tys `lengthAtLeast` (tyConArity tc) - = Just (expand_syn tvs rhs arg_tys) - | otherwise - = Nothing - --- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path --- into call-sites. --- --- Precondition: the call is saturated or over-saturated; --- i.e. length tvs <= length arg_tys -expand_syn :: [TyVar] -- ^ the variables bound by the synonym - -> Type -- ^ the RHS of the synonym - -> [Type] -- ^ the type arguments the synonym is instantiated at. - -> Type -{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. - -expand_syn tvs rhs arg_tys - -- No substitution necessary if either tvs or tys is empty - -- This is both more efficient, and steers clear of an infinite - -- loop; see Note [Care using synonyms to compress types] - | null arg_tys = assert (null tvs) rhs - | null tvs = mkAppTys rhs arg_tys - | otherwise = go empty_subst tvs arg_tys - where - empty_subst = mkEmptyTCvSubst in_scope - in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys - -- The free vars of 'rhs' should all be bound by 'tenv', - -- so we only need the free vars of tys - -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. - - go subst [] tys - | null tys = rhs' -- Exactly Saturated - | otherwise = mkAppTys rhs' tys - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! - where - rhs' = substTy subst rhs - - go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys - - go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) - -- Under-saturated, precondition failed - - - -coreFullView :: Type -> Type --- ^ Iterates 'coreView' until there is no more to synonym to expand. --- 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 - - f :: Type -> ... - f ty | Just ty' <- coreView ty = f ty' - f (TyVarTy ...) = ... - f ... = ... - -If f is not otherwise recursive, the initial call to coreView -causes f to become recursive, which kills the possibility of -inlining. Instead, for non-recursive functions, we prefer to -use coreFullView, which guarantees to unwrap top-level type -synonyms. It can be inlined and is efficient and non-allocating -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 :: 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) --- But we don't know which those are currently, so we just expand all. --- --- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, --- not in the kinds of any TyCon or TyVar mentioned in the type. --- --- Keep this synchronized with 'synonymTyConsOfType' -expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty - where - in_scope = mkInScopeSet (tyCoVarsOfType ty) - - go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys - = let subst' = mkTvSubst in_scope (mkVarEnv tenv) - -- Make a fresh substitution; rhs has nothing to - -- do with anything that has happened so far - -- NB: if you make changes here, be sure to build an - -- /idempotent/ substitution, even in the nested case - -- type T a b = a -> b - -- type S x y = T y x - -- (#11665) - in mkAppTys (go subst' rhs) tys' - | otherwise - = TyConApp tc expanded_tys - where - expanded_tys = (map (go subst) tys) - - go _ (LitTy l) = LitTy l - go subst (TyVarTy tv) = substTyVar subst tv - go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst ty@(FunTy _ mult arg res) - = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } - go subst (ForAllTy (Bndr tv vis) t) - = let (subst', tv') = substVarBndrUsing go subst tv in - ForAllTy (Bndr tv' vis) (go subst' t) - go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) - go subst (CoercionTy co) = mkCoercionTy (go_co subst co) - - go_mco _ MRefl = MRefl - go_mco subst (MCo co) = MCo (go_co subst co) - - go_co subst (Refl ty) - = mkNomReflCo (go subst ty) - go_co subst (GRefl r ty mco) - = mkGReflCo r (go subst ty) (go_mco subst mco) - -- NB: coercions are always expanded upon creation - go_co subst (TyConAppCo r tc args) - = mkTyConAppCo r tc (map (go_co subst) args) - go_co subst (AppCo co arg) - = mkAppCo (go_co subst co) (go_co subst arg) - 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 (CoVarCo cv) - = substCoVar subst cv - go_co subst (AxiomInstCo ax ind args) - = mkAxiomInstCo ax ind (map (go_co subst) args) - go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) - go_co subst (SymCo co) - = 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 (LRCo lr co) - = mkLRCo lr (go_co subst co) - go_co subst (InstCo co arg) - = mkInstCo (go_co subst co) (go_co subst arg) - go_co subst (KindCo co) - = mkKindCo (go_co subst co) - go_co subst (SubCo co) - = mkSubCo (go_co subst co) - go_co subst (AxiomRuleCo ax cs) - = AxiomRuleCo ax (map (go_co subst) cs) - go_co _ (HoleCo h) - = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - go_prov _ p@(CorePrepProv _) = p - - -- the "False" and "const" are to accommodate the type of - -- substForAllCoBndrUsing, which is general enough to - -- handle coercion optimization (which sometimes swaps the - -- order of a coercion) - go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst - --- | An INLINE helper for function such as 'kindRep_maybe' below. --- --- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff --- the type @ty = T tys@, where T's unique = key -isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type] -isTyConKeyApp_maybe key ty - | TyConApp tc args <- coreFullView ty - , tc `hasKey` key - = Just args - | otherwise - = Nothing -{-# INLINE isTyConKeyApp_maybe #-} - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -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. --- 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 Type -kindRep_maybe kind - | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg - | otherwise = Nothing - --- | Returns True if the kind classifies types which are allocated on --- the GC'd heap and False otherwise. Note that this returns False for --- representation-polymorphic kinds, which may be specialized to a kind that --- classifies AddrRep or even unboxed kinds. -isBoxedTypeKind :: Kind -> Bool -isBoxedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isBoxedRuntimeRep rep - Nothing -> False - --- | 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] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - -pickyIsLiftedTypeKind :: Kind -> Bool --- Checks whether the kind is literally --- TYPE LiftedRep --- or TYPE ('BoxedRep 'Lifted) --- or Type --- without expanding type synonyms or anything --- Used only when deciding whether to suppress the ":: *" in --- (a :: *) when printing kinded type variables --- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr -pickyIsLiftedTypeKind kind - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey - , TyConApp rr_tc rr_args <- arg = case rr_args of - [] -> rr_tc `hasKey` liftedRepTyConKey - [rr_arg] - | rr_tc `hasKey` boxedRepDataConKey - , TyConApp lev [] <- rr_arg - , lev `hasKey` liftedDataConKey -> True - _ -> False - | TyConApp tc [] <- kind - , tc `hasKey` liftedTypeKindTyConKey = True - | otherwise = False - --- | 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 type of kind 'RuntimeRep' is lifted. --- --- 'isLiftedRuntimeRep' is: --- --- * True of @LiftedRep :: RuntimeRep@ --- * False of type variables, type family applications, --- and of other reps such as @IntRep :: RuntimeRep@. -isLiftedRuntimeRep :: Type -> Bool -isLiftedRuntimeRep rep = - runtimeRepLevity_maybe rep == Just Lifted - --- | Check whether a type of kind 'RuntimeRep' is unlifted. --- --- * True of definitely unlifted 'RuntimeRep's such as --- 'UnliftedRep', 'IntRep', 'FloatRep', ... --- * False of 'LiftedRep', --- * False for type variables and type family applications. -isUnliftedRuntimeRep :: Type -> Bool -isUnliftedRuntimeRep rep = - runtimeRepLevity_maybe rep == Just Unlifted - --- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. --- --- Checks whether the type is a nullary 'TyCon' application, --- for a 'TyCon' with the given 'Unique'. -isNullaryTyConKeyApp :: Unique -> Type -> Bool -isNullaryTyConKeyApp key ty - | Just args <- isTyConKeyApp_maybe key ty - = assert (null args) True - | otherwise - = False -{-# INLINE isNullaryTyConKeyApp #-} - -isLiftedLevity :: Type -> Bool -isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey - -isUnliftedLevity :: Type -> Bool -isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey - --- | Is this the type 'Levity'? -isLevityTy :: Type -> Bool -isLevityTy = isNullaryTyConKeyApp levityTyConKey - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - --- | Is a tyvar of type 'Levity'? -isLevityVar :: TyVar -> Bool -isLevityVar = isLevityTy . tyVarKind - --- | Is this the type 'Multiplicity'? -isMultiplicityTy :: Type -> Bool -isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey - --- | Is a tyvar of type 'Multiplicity'? -isMultiplicityVar :: TyVar -> Bool -isMultiplicityVar = isMultiplicityTy . tyVarKind - -{- ********************************************************************* -* * - mapType -* * -************************************************************************ - -These functions do a map-like operation over types, performing some operation -on all variables and binding sites. Primarily used for zonking. - -Note [Efficiency for ForAllCo case of mapTyCoX] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. -It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches -the left-hand kind of the coercion. This is convenient lots of the time, but -not when mapping a function over a coercion. - -The problem is that tcm_tybinder will affect the TyCoVar's kind and -mapCoercion will affect the Coercion, and we hope that the results will be -the same. Even if they are the same (which should generally happen with -correct algorithms), then there is an efficiency issue. In particular, -this problem seems to make what should be a linear algorithm into a potentially -exponential one. But it's only going to be bad in the case where there's -lots of foralls in the kinds of other foralls. Like this: - - forall a : (forall b : (forall c : ...). ...). ... - -This construction seems unlikely. So we'll do the inefficient, easy way -for now. - -Note [Specialising mappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used -to implement zonking, and it's vital that they get specialised to the TcM -monad and the particular mapper in use. - -Even specialising to the monad alone made a 20% allocation difference -in perf/compiler/T5030. - -See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this -idiom. --} - --- | This describes how a "map" operation over a type/coercion should behave -data TyCoMapper env m - = TyCoMapper - { tcm_tyvar :: env -> TyVar -> m Type - , tcm_covar :: env -> CoVar -> m Coercion - , tcm_hole :: env -> CoercionHole -> m Coercion - -- ^ What to do with coercion holes. - -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - - , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) - -- ^ The returned env is used in the extended scope - - , tcm_tycon :: TyCon -> m TyCon - -- ^ This is used only for TcTyCons - -- a) To zonk TcTyCons - -- b) To turn TcTyCons into TyCons. - -- See Note [Type checking recursive type and class declarations] - -- in "GHC.Tc.TyCl" - } - -{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] -mapTyCo :: Monad m => TyCoMapper () m - -> ( Type -> m Type - , [Type] -> m [Type] - , Coercion -> m Coercion - , [Coercion] -> m[Coercion]) -mapTyCo mapper - = case mapTyCoX mapper of - (go_ty, go_tys, go_co, go_cos) - -> (go_ty (), go_tys (), go_co (), go_cos ()) - -{-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] -mapTyCoX :: Monad m => TyCoMapper env m - -> ( env -> Type -> m Type - , env -> [Type] -> m [Type] - , env -> Coercion -> m Coercion - , env -> [Coercion] -> m[Coercion]) -mapTyCoX (TyCoMapper { tcm_tyvar = tyvar - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon - , tcm_covar = covar - , tcm_hole = cohole }) - = (go_ty, go_tys, go_co, go_cos) - where - go_tys _ [] = return [] - go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys - - go_ty env (TyVarTy tv) = tyvar env tv - go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 - go_ty _ ty@(LitTy {}) = return ty - go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co - go_ty env (CoercionTy co) = CoercionTy <$> go_co env co - - go_ty env ty@(FunTy _ w arg res) - = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res - ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } - - go_ty env ty@(TyConApp tc tys) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConApp tc' <$> go_tys env tys } - - -- Not a TcTyCon - | null tys -- Avoid allocation in this very - = return ty -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConApp tc <$> go_tys env tys - - go_ty env (ForAllTy (Bndr tv vis) inner) - = do { (env', tv') <- tycobinder env tv vis - ; inner' <- go_ty env' inner - ; return $ ForAllTy (Bndr tv' vis) inner' } - - go_cos _ [] = return [] - go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos - - 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 co@(TyConAppCo r tc cos) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConAppCo r tc' <$> go_cos env cos } - - -- Not a TcTyCon - | null cos -- Avoid allocation in this very - = return co -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConAppCo r tc <$> go_cos env cos - go_co env (ForAllCo tv kind_co co) - = do { kind_co' <- go_co env kind_co - ; (env', tv') <- tycobinder env tv Inferred - ; co' <- go_co env' co - ; return $ mkForAllCo tv' kind_co' co' } - -- See Note [Efficiency for ForAllCo case of mapTyCoX] - - go_prov env (PhantomProv co) = PhantomProv <$> go_co env co - go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p - - -{- -************************************************************************ -* * -\subsection{Constructor-specific functions} -* * -************************************************************************ - - ---------------------------------------------------------------------- - 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 - Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) - --- | Attempts to obtain the type variable underlying a 'Type' -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe = repGetTyVar_maybe . coreFullView - --- | 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) -getCastedTyVar_maybe ty = case coreFullView ty of - CastTy (TyVarTy tv) co -> Just (tv, co) - 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 -invariant that a TyConApp is always visibly so. mkAppTy maintains the -invariant: use it. - -Note [Decomposing fat arrow c=>t] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can we unify (a b) with (Eq a => ty)? If we do so, we end up with -a partial application like ((=>) Eq a) which doesn't make sense in -source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). -Here's an example (#9858) of how you might do it: - i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep - i p = typeRep p - - j = i (Proxy :: Proxy (Eq Int => Int)) -The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, -but suppose we want that. But then in the call to 'i', we end -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 other calls to splitAppTy are in GHC.Core.Unify, which is also used by -the type checker (e.g. when matching type-function equations). - --} - --- | Applies a type to another, as in e.g. @k a@ -mkAppTy :: Type -> Type -> Type - -- See Note [Respecting definitional equality], invariant (EQ1). -mkAppTy (CastTy fun_ty co) arg_ty - | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] - = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co - -mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) -mkAppTy ty1 ty2 = AppTy ty1 ty2 - -- Note that the TyConApp could be an - -- under-saturated type synonym. GHC allows that; e.g. - -- type Foo k = k a -> k a - -- type Id x = x - -- foo :: Foo Id -> Foo Id - -- - -- Here Id is partially applied in the type sig for Foo, - -- but once the type synonyms are expanded all is well - -- - -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type - -- (T t1 t2 t3) one argument at a type, thus forming - -- (T t1), (T t1 t2), etc - -mkAppTys :: Type -> [Type] -> Type -mkAppTys ty1 [] = ty1 -mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy - -- Why do this? See (EQ1) of - -- Note [Respecting definitional equality] - -- in GHC.Core.TyCo.Rep - = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers - where - (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys - (args_to_cast, leftovers) = splitAtList arg_cos arg_tys - casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos -mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) -mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 - -------------- -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 - -------------- -repSplitAppTy_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) - = Just (ty1, ty2) - -repSplitAppTy_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! - -repSplitAppTy_maybe _other = Nothing - --- This one doesn't break apart (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 - = 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" - -------------- -splitAppTys :: Type -> (Type, [Type]) --- ^ Recursively splits a type as far as is possible, leaving a residual --- type being applied to and the type arguments applied to it. Never fails, --- even if that means returning an empty list of type applications. -splitAppTys ty = split ty ty [] - where - split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - 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 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ w ty1 ty2) args - = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - 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 [] - where - split (AppTy ty arg) args = split ty (arg:args) - split (TyConApp tc tc_args) args - = let n | mustBeSaturated 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 - = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split ty args = (ty, args) - -{- - LitTy - ~~~~~ --} - -mkNumLitTy :: Integer -> Type -mkNumLitTy n = LitTy (NumTyLit n) - --- | Is this a numeric literal. We also look through type synonyms. -isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty - | LitTy (NumTyLit n) <- coreFullView ty = Just n - | otherwise = Nothing - -mkStrLitTy :: FastString -> Type -mkStrLitTy s = LitTy (StrTyLit s) - --- | Is this a symbol literal. We also look through type synonyms. -isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty - | LitTy (StrTyLit s) <- coreFullView ty = Just s - | otherwise = Nothing - -mkCharLitTy :: Char -> Type -mkCharLitTy c = LitTy (CharTyLit c) - --- | Is this a char literal? We also look through type synonyms. -isCharLitTy :: Type -> Maybe Char -isCharLitTy ty - | LitTy (CharTyLit s) <- coreFullView ty = Just s - | otherwise = Nothing - - --- | Is this a type literal (symbol, numeric, or char)? -isLitTy :: Type -> Maybe TyLit -isLitTy ty - | LitTy l <- coreFullView ty = Just l - | otherwise = Nothing - --- | Is this type a custom user error? --- If so, give us the kind and the error message. -userTypeError_maybe :: Type -> Maybe Type -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } - --- | Render a type corresponding to a user type error into a SDoc. -pprUserTypeErrorTy :: Type -> SDoc -pprUserTypeErrorTy ty = - case splitTyConApp_maybe ty of - - -- Text "Something" - Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName - , Just str <- isStrLitTy txt -> ftext str - - -- ShowType t - Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t - - -- t1 :<>: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> - pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 - - -- t1 :$$: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> - pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 - - -- An unevaluated type function - _ -> ppr ty - - - - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -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) - - (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> Type - -However, for efficiency's sake we represent saturated applications of (->) -with FunTy. For instance, the type, - - (->) r1 r2 a b - -is equivalent to, - - FunTy (Anon a) b - -Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when reconstructing the TyConApp representation (see, -for instance, splitTyConApp_maybe). - -In the compiler we maintain the invariant that all saturated applications of -(->) are represented with FunTy. - -See #11714. --} - -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 - -{-# INLINE splitFunTy_maybe #-} -splitFunTy_maybe :: Type -> Maybe (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 - -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 orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args orig_ty _ = (reverse args, orig_ty) - -funResultTy :: HasDebugCallStack => Type -> Type --- ^ Extract the function result type and panic if that is not possible -funResultTy ty - | FunTy { ft_res = res } <- coreFullView ty = res - | otherwise = pprPanic "funResultTy" (ppr ty) - -funArgTy :: Type -> Type --- ^ Extract the function argument type and panic if that is not possible -funArgTy ty - | FunTy { ft_arg = arg } <- coreFullView ty = arg - | otherwise = pprPanic "funArgTy" (ppr ty) - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" -piResultTy :: HasDebugCallStack => Type -> Type -> Type -piResultTy ty arg = case piResultTy_maybe ty arg of - Just res -> res - Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) - -piResultTy_maybe :: Type -> Type -> Maybe Type --- We don't need a 'tc' version, because --- this function behaves the same for Type and Constraint -piResultTy_maybe ty arg = case coreFullView ty of - FunTy { ft_res = res } -> Just res - - ForAllTy (Bndr tv _) res - -> let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTCvSubst empty_subst tv arg) res) - - _ -> Nothing - --- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) --- where f :: f_ty --- 'piResultTys' is interesting because: --- 1. 'f_ty' may have more for-alls than there are args --- 2. Less obviously, it may have fewer for-alls --- For case 2. think of: --- piResultTys (forall a.a) [forall b.b, Int] --- This really can happen, but only (I think) in situations involving --- undefined. For example: --- undefined :: forall a. a --- Term: undefined @(forall b. b->b) @Int --- This term should have type (Int -> Int), but notice that --- there are more type args than foralls in 'undefined's type. - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint - --- This is a heavily used function (e.g. from typeKind), --- so we pay attention to efficiency, especially in the special case --- where there are no for-alls so we are just dropping arrows from --- a function type/kind. -piResultTys :: HasDebugCallStack => Type -> [Type] -> Type -piResultTys ty [] = ty -piResultTys ty orig_args@(arg:args) - | FunTy { ft_res = res } <- ty - = piResultTys res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst init_subst tv arg) res args - - | Just ty' <- coreView ty - = piResultTys ty' orig_args - - | otherwise - = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) - where - init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - - go :: TCvSubst -> Type -> [Type] -> Type - go subst ty [] = substTyUnchecked subst ty - - go subst ty all_args@(arg:args) - | FunTy { ft_res = res } <- ty - = go subst res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst subst tv arg) res args - - | Just ty' <- coreView ty - = go subst ty' all_args - - | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] - = go init_subst - (substTy subst ty) - all_args - - | otherwise - = -- We have not run out of arguments, but the function doesn't - -- have the right kind to apply to them; so panic. - -- Without the explicit isEmptyVarEnv test, an ill-kinded type - -- would give an infinite loop, which is very unhelpful - -- c.f. #15473 - pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) - -applyTysX :: [TyVar] -> Type -> [Type] -> Type --- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys --- Assumes that (/\tvs. body_ty) is closed -applyTysX tvs body_ty arg_tys - = assertPpr (tvs `leLength` arg_tys) pp_stuff $ - assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ - mkAppTys (substTyWith tvs arg_tys_prefix body_ty) - arg_tys_rest - where - pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] - (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys - - - -{- Note [Care with kind instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - T :: forall k. k -and we are finding the kind of - T (forall b. b -> b) * Int -Then - T (forall b. b->b) :: k[ k :-> forall b. b->b] - :: forall b. b -> b -So - T (forall b. b->b) * :: (b -> b)[ b :-> *] - :: * -> * - -In other words we must instantiate the forall! - -Similarly (#15428) - S :: forall k f. k -> f k -and we are finding the kind of - S * (* ->) Int Bool -We have - S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] - :: * -> * -> * -So again we must instantiate. - -The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. - ---------------------------------------------------------------------- - 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 .. - --- | 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 - - --- | The same as @fst . splitTyConApp@ -{-# INLINE tyConAppTyCon_maybe #-} -tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty = case coreFullView ty of - TyConApp tc _ -> Just tc - FunTy {} -> Just funTyCon - _ -> 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 :: 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) - --- | 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: --- 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 - -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. --- This requires tys to have at least @newTyConInstArity tycon@ elements. -newTyConInstRhs tycon tys - = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ - applyTysX tvs rhs tys - where - (tvs, rhs) = newTyConEtadRhs tycon - -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. --} - -splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty - | CastTy ty' co <- coreFullView ty = Just (ty', co) - | otherwise = Nothing - --- | Make a 'CastTy'. The Coercion must be nominal. Checks the --- Coercion for reflexivity, dropping it if it's reflexive. --- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" -mkCastTy :: Type -> Coercion -> Type -mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note --- NB: Do the slow check here. This is important to keep the splitXXX --- functions working properly. Otherwise, we may end up with something --- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) --- fails under splitFunTy_maybe. This happened with the cheaper check --- in test dependent/should_compile/dynamic-paper. -mkCastTy orig_ty co = mk_cast_ty orig_ty co - --- | Like 'mkCastTy', but avoids checking the coercion for reflexivity, --- as that can be expensive. -mk_cast_ty :: Type -> Coercion -> Type -mk_cast_ty orig_ty co = go orig_ty - where - go :: Type -> Type - -- See Note [Using coreView in mk_cast_ty] - go ty | Just ty' <- coreView ty = go ty' - - go (CastTy ty co1) - -- (EQ3) from the Note - = mkCastTy ty (co1 `mkTransCo` co) - -- call mkCastTy again for the reflexivity check - - go (ForAllTy (Bndr tv vis) inner_ty) - -- (EQ4) from the Note - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. - | isTyVar tv - , let fvs = tyCoVarsOfCo co - = -- have to make sure that pushing the co in doesn't capture the bound var! - if tv `elemVarSet` fvs - then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) - (subst, tv') = substVarBndr empty_subst tv - in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) - else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) - - go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible - -{- -Note [Using coreView in mk_cast_ty] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in -GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance, -consider this example (#19742): - - type EqSameNat = () |> co - useNatEq :: EqSameNat |> sym co - -(Those casts aren't visible in the user-source code, of course; see #19742 for -what the user might write.) - -The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no -nested casts, but if we expand EqSameNat, we see that it doesn't. -And then Bad Things happen. - -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 :: Type -> Type -mkTYPEapp rr - = case mkTYPEapp_maybe rr of - Just ty -> ty - Nothing -> TyConApp tYPETyCon [rr] - -mkTYPEapp_maybe :: Type -> Maybe Type --- ^ Given a @RuntimeRep@, applies @TYPE@ to it. --- On the fly it rewrites --- TYPE LiftedRep --> liftedTypeKind (a synonym) --- TYPE UnliftedRep --> unliftedTypeKind (ditto) --- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) --- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) --- because those inner types should already have been rewritten --- to LiftedRep and UnliftedRep respectively, by mkTyConApp --- --- see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkTYPEapp_maybe #-} -mkTYPEapp_maybe (TyConApp tc args) - | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep - | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep - | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep - where - key = tyConUnique tc -mkTYPEapp_maybe _ = Nothing - -mkBoxedRepApp_maybe :: Type -> Maybe Type --- ^ Given a `Levity`, apply `BoxedRep` to it --- On the fly, rewrite --- BoxedRep Lifted --> liftedRepTy (a synonym) --- BoxedRep Unlifted --> unliftedRepTy (ditto) --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkBoxedRepApp_maybe #-} -mkBoxedRepApp_maybe (TyConApp tc args) - | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted - | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted - where - key = tyConUnique tc -mkBoxedRepApp_maybe _ = Nothing - -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. --} - -mkCoercionTy :: Coercion -> Type -mkCoercionTy = CoercionTy - -isCoercionTy :: Type -> Bool -isCoercionTy (CoercionTy _) = True -isCoercionTy _ = False - -isCoercionTy_maybe :: Type -> Maybe Coercion -isCoercionTy_maybe (CoercionTy co) = Just co -isCoercionTy_maybe _ = Nothing - -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 - ~~~~~~~~ --} - --- | Make a dependent forall over an 'Inferred' variable -mkTyCoInvForAllTy :: TyCoVar -> Type -> Type -mkTyCoInvForAllTy tv ty - | isCoVar tv - , not (tv `elemVarSet` tyCoVarsOfType ty) - = mkVisFunTyMany (varType tv) ty - | otherwise - = ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar -mkInfForAllTy :: TyVar -> Type -> Type -mkInfForAllTy tv ty = assert (isTyVar tv ) - ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Inferred', a common case -mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type -mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs - --- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar -mkInfForAllTys :: [TyVar] -> Type -> Type -mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs - --- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', --- a common case -mkSpecForAllTy :: TyVar -> Type -> Type -mkSpecForAllTy tv ty = assert (isTyVar tv ) - -- covar is always Inferred, so input should be tyvar - ForAllTy (Bndr tv Specified) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Specified', a common case -mkSpecForAllTys :: [TyVar] -> Type -> Type -mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs - --- | Like mkForAllTys, but assumes all variables are dependent and visible -mkVisForAllTys :: [TyVar] -> Type -> Type -mkVisForAllTys tvs = assert (all isTyVar tvs ) - -- covar is always Inferred, so all inputs should be tyvar - 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 --- 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 --- --- All non-coercion binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -- ^ binders - -> TyCoVarSet -- ^ free variables of result - -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) - fst (go vars) - where - go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], inner_tkvs) - go (v:vs) | v `elemVarSet` fvs - = ( Bndr v (NamedTCB Required) : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( Bndr v (AnonTCB VisArg) : binders - , fvs `unionVarSet` kind_vars ) - where - (binders, fvs) = go vs - kind_vars = tyCoVarsOfType $ tyVarKind v - --- | 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. -splitForAllTyCoVars :: Type -> ([TyCoVar], Type) -splitForAllTyCoVars ty = split ty ty [] - where - split _ (ForAllTy (Bndr tv _) ty) tvs = 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) - --- | 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 [] - 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) - --- | 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 - where - argf_pred :: ArgFlag -> Maybe () - argf_pred Required = Just () - argf_pred (Invisible {}) = Nothing - --- | 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 [] - 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) - --- | Checks whether this is a proper forall (with a named binder) -isForAllTy :: Type -> Bool -isForAllTy ty - | ForAllTy {} <- coreFullView ty = True - | otherwise = False - --- | Like `isForAllTy`, but returns True only if it is a tyvar binder -isForAllTy_ty :: Type -> Bool -isForAllTy_ty ty - | ForAllTy (Bndr tv _) _ <- coreFullView ty - , isTyVar tv - = True - - | otherwise = False - --- | Like `isForAllTy`, but returns True only if it is a covar binder -isForAllTy_co :: Type -> Bool -isForAllTy_co ty - | ForAllTy (Bndr tv _) _ <- coreFullView ty - , isCoVar tv - = True - - | otherwise = False - --- | Is this a function or forall? -isPiTy :: Type -> Bool -isPiTy ty = case coreFullView ty of - ForAllTy {} -> True - FunTy {} -> True - _ -> False - --- | Is this a function? -isFunTy :: Type -> Bool -isFunTy ty - | FunTy {} <- coreFullView ty = True - | otherwise = False - --- | Take a forall type apart, or panics if that is not possible. -splitForAllTyCoVar :: Type -> (TyCoVar, Type) -splitForAllTyCoVar ty - | Just answer <- splitForAllTyCoVar_maybe ty = answer - | otherwise = pprPanic "splitForAllTyCoVar" (ppr ty) - --- | Drops all ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty = go ty - where - go (ForAllTy _ res) = go res - go ty | Just ty' <- coreView ty = go ty' - go res = res - --- | Attempts to take a forall type apart, but only if it's a proper forall, --- with a named binder -splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTyCoVar_maybe ty - | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) - | otherwise = Nothing - --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder. -splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTyVar_maybe ty - | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty - , isTyVar tv - = Just (tv, inner_ty) - - | otherwise = Nothing - --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. -splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllCoVar_maybe ty - | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty - , isCoVar tv - = Just (tv, inner_ty) - - | otherwise = Nothing - --- | 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 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) - _ -> Nothing - --- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyCoBinder, 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 --- and functions -splitPiTys :: Type -> ([TyCoBinder], 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 orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Extracts a list of run-time arguments from a function type, --- looking through newtypes to the right of arrows. --- --- Examples: --- --- @ --- 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)] --- @ --- --- Note that, in the last case, the returned types might mention an out-of-scope --- type variable. This function is used only when we really care about the /kinds/ --- of the returned types, so this is OK. --- --- **Warning**: this function can return an infinite list. For example: --- --- @ --- newtype N a = MkN (a -> N a) --- getRuntimeArgTys (N a) == repeat (a, VisArg) --- @ -getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)] -getRuntimeArgTys = go - where - go :: Type -> [(Type, AnonArgFlag)] - go (ForAllTy _ res) - = go res - go (FunTy { ft_arg = arg, ft_res = res, ft_af = af }) - = (arg, af) : go res - go ty - | Just ty' <- coreView ty - = go ty' - | Just (_,ty') <- topNormaliseNewType_maybe ty - = go ty' - | 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 --- e.g. forall {k}. (k ~ *) => k -> k --- returns 2 not 1 -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 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) - 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) --- ^ Same as 'splitInvisPiTys', but stop when --- - you have found @n@ 'TyCoBinder's, --- - or you run out of invisible binders -splitInvisPiTysN n ty = split n ty ty [] - where - split n orig_ty ty bs - | n == 0 = (reverse bs, orig_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) - --- | Given a 'TyCon' and a list of argument types, filter out any invisible --- (i.e., 'Inferred' or 'Specified') arguments. -filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] -filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys - --- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' --- arguments. -filterOutInferredTypes :: TyCon -> [Type] -> [Type] -filterOutInferredTypes tc tys = - filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys - --- | Given a 'TyCon' and a list of argument types, partition the arguments --- into: --- --- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and --- --- 2. 'Required' (i.e., visible) arguments -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) -partitionInvisibleTypes tc tys = - partitionByList (map isInvisibleArgFlag $ tyConArgFlags 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 = partitionWith pick_invis - where - pick_invis :: (a, ArgFlag) -> Either a a - pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing - | otherwise = Right thing - --- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Wrinkle: consider the following scenario: --- --- > T :: forall k. k -> k --- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] --- --- After substituting, we get --- --- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n --- --- 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) - --- | Given a 'Type' and a list of argument types to which the 'Type' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- 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, --- 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) - --- | 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 = go emptyTCvSubst - where - go subst ki arg_tys - | Just ki' <- coreView ki = go subst ki' arg_tys - go _ _ [] = [] - go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) - = argf : go subst' res_ki arg_tys - where - subst' = extendTvSubst subst tv arg_ty - go subst (TyVarTy tv) arg_tys - | Just ki <- lookupTyVar subst tv = go subst ki arg_tys - -- This FunTy case is important to handle kinds with nested foralls, such - -- as this kind (inspired by #16518): - -- - -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type - -- - -- Here, we want to get the following ArgFlags: - -- - -- [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 - go _ _ arg_tys = map (const Required) arg_tys - -- something is ill-kinded. But this can happen - -- when printing errors. Assume everything is Required. - --- @isTauTy@ tests if a type has no foralls or (=>) -isTauTy :: Type -> Bool -isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -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 (ForAllTy {}) = False -isTauTy (CastTy ty _) = isTauTy ty -isTauTy (CoercionTy _) = False -- Not sure about this - -isAtomicTy :: Type -> Bool --- True if the type is just a single token, and can be printed compactly --- Used when deciding how to lay out type error messages; see the --- call in GHC.Tc.Errors -isAtomicTy (TyVarTy {}) = True -isAtomicTy (LitTy {}) = True -isAtomicTy (TyConApp _ []) = True - -isAtomicTy ty | isLiftedTypeKind ty = True - -- 'Type' prints compactly as * - -- See GHC.Iface.Type.ppr_kind_type - -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} -* * -************************************************************************ --} - -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ - zipTvSubst tvs tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys - --- | Get the type on the LHS of a coercion induced by a type/data --- family instance. -coAxNthLHS :: CoAxiom br -> Int -> Type -coAxNthLHS ax ind = - mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) - -isFamFreeTy :: Type -> Bool -isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' -isFamFreeTy (TyVarTy _) = True -isFamFreeTy (LitTy {}) = True -isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc -isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b -isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty -isFamFreeTy (CastTy ty _) = isFamFreeTy ty -isFamFreeTy (CoercionTy _) = False -- Not sure about this - --- | Does this type classify a core (unlifted) Coercion? --- At either role nominal or representational --- (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" -isCoVarType :: Type -> Bool - -- ToDo: should we check saturation? -isCoVarType ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - | otherwise - = False - -buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> KnotTied Type -> TyCon --- This function is here because here is where we have --- isFamFree and isTauTy -buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful - where - is_tau = isTauTy rhs - is_fam_free = isFamFreeTy rhs - is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders || - uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs) - -- NB: This is allowed to be conservative, returning True more often - -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon - -{- -************************************************************************ -* * -\subsection{Liftedness} -* * -************************************************************************ --} - --- | Tries to compute the 'Levity' of the given type. Returns either --- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the --- type is representation-polymorphic). --- --- Panics if the kind does not have the shape @TYPE r@. -typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity -typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) - --- | Is the given type definitely unlifted? --- See "Type#type_classification" for what an unlifted type is. --- --- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for --- a more approximate predicate that behaves better in the presence of --- representation polymorphism. -isUnliftedType :: HasDebugCallStack => Type -> Bool - -- isUnliftedType returns True for forall'd unlifted types: - -- x :: forall a. Int# - -- I found bindings like these were getting floated to the top level. - -- They are pretty bogus types, mind you. It would be better never to - -- construct them -isUnliftedType ty = - case typeLevity_maybe ty of - Just Lifted -> False - Just Unlifted -> True - Nothing -> - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - --- | State token type. -isStateType :: Type -> Bool -isStateType ty - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - --- | Returns: --- --- * 'False' if the type is /guaranteed/ unlifted or --- * 'True' if it lifted, OR we aren't sure --- (e.g. in a representation-polymorphic case) -mightBeLiftedType :: Type -> Bool -mightBeLiftedType = mightBeLifted . typeLevity_maybe - --- | Returns: --- --- * 'False' if the type is /guaranteed/ lifted or --- * 'True' if it is unlifted, OR we aren't sure --- (e.g. in a representation-polymorphic case) -mightBeUnliftedType :: Type -> Bool -mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe - --- | See "Type#type_classification" for what a boxed type is. --- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for --- a more approximate predicate that behaves better in the presence of --- representation polymorphism. -isBoxedType :: Type -> Bool -isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) - --- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) -isRuntimeRepKindedTy :: Type -> Bool -isRuntimeRepKindedTy = isRuntimeRepTy . typeKind - --- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: --- --- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep --- , String, Int# ] == [String, Int#] --- -dropRuntimeRepArgs :: [Type] -> [Type] -dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not --- possible. -getRuntimeRep_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRep_maybe = kindRep_maybe . typeKind - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type -getRuntimeRep ty - = case getRuntimeRep_maybe ty of - Just r -> r - Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - --- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, --- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. --- --- Returns 'Nothing' if this is not possible. Does not look through type family applications. -getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type -getLevity_maybe ty - | Just rep <- getRuntimeRep_maybe ty - , Just (tc, [lev]) <- splitTyConApp_maybe rep - , tc == boxedRepDataConTyCon - = Just lev - | otherwise - = Nothing - --- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, --- or @getLevity (Array# Int) = Unlifted@. --- --- Panics if this is not possible. Does not look through type family applications. -getLevity :: HasDebugCallStack => Type -> Type -getLevity ty - | Just lev <- getLevity_maybe ty - = lev - | otherwise - = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - -isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey - -- NB: Do not use typePrimRep, as that can't tell the difference between - -- unboxed tuples and unboxed sums - - -isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors -isAlgType :: Type -> Bool -isAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc - _other -> False - --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - --- | Computes whether an argument (or let right hand side) should --- be computed strictly or lazily, based only on its type. --- Currently, it's just 'isUnliftedType'. --- Panics on representation-polymorphic types. -isStrictType :: HasDebugCallStack => Type -> Bool -isStrictType = isUnliftedType - -isPrimitiveType :: Type -> Bool --- ^ Returns true of types that are opaque to Haskell. -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) - isPrimTyCon tc - _ -> False - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Determine whether a type could be the type of a join point of given total --- arity, according to the polymorphism rule. A join point cannot be polymorphic --- in its return type, since given --- join j @a @b x y z = e1 in e2, --- the types of e1 and e2 must be the same, and a and b are not in scope for e2. --- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False --- also if the type simply doesn't have enough arguments. --- --- Note that we need to know how many arguments (type *and* value) the putative --- join point takes; for instance, if --- j :: forall a. a -> Int --- then j could be a binary join point returning an Int, but it could *not* be a --- unary join point returning a -> Int. --- --- TODO: See Note [Excess polymorphism and join points] -isValidJoinPointType :: JoinArity -> Type -> Bool -isValidJoinPointType arity ty - = valid_under emptyVarSet arity ty - where - valid_under tvs arity ty - | arity == 0 - = tvs `disjointVarSet` tyCoVarsOfType ty - | Just (t, ty') <- splitForAllTyCoVar_maybe ty - = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, _, res_ty) <- splitFunTy_maybe ty - = valid_under tvs (arity-1) res_ty - | otherwise - = False - -{- Note [Excess polymorphism and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In principle, if a function would be a join point except that it fails -the polymorphism rule (see Note [The polymorphism rule of join points] in -GHC.Core), it can still be made a join point with some effort. This is because -all tail calls must return the same type (they return to the same context!), and -thus if the return type depends on an argument, that argument must always be the -same. - -For instance, consider: - - let f :: forall a. a -> Char -> [a] - f @a x c = ... f @a y 'a' ... - in ... f @Int 1 'b' ... f @Int 2 'c' ... - -(where the calls are tail calls). `f` fails the polymorphism rule because its -return type is [a], where [a] is bound. But since the type argument is always -'Int', we can rewrite it as: - - let f' :: Int -> Char -> [Int] - f' x c = ... f' y 'a' ... - in ... f' 1 'b' ... f 2 'c' ... - -and now we can make f' a join point: - - join f' :: Int -> Char -> [Int] - f' x c = ... jump f' y 'a' ... - in ... jump f' 1 'b' ... jump f' 2 'c' ... - -It's not clear that this comes up often, however. TODO: Measure how often and -add this analysis if necessary. See #14620. - - -************************************************************************ -* * -\subsection{Sequencing on types} -* * -************************************************************************ --} - -seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co - -seqTypes :: [Type] -> () -seqTypes [] = () -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 [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 (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 `thenCmp` 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 - `thenCmp` - 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 - `a` is not free in rep -(FORALL1) ----------------------- - forall a. ty : TYPE rep - - ty : Constraint -(FORALL2) ------------------------- - forall a. ty : Constraint - -Note that: -* The only way we distinguish '->' from '=>' is by the fact - that the argument is a PredTy. Both are FunTys - -Note [Phantom type variables in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - type K (r :: RuntimeRep) = Type -- Note 'r' is unused - data T r :: K r -- T :: forall r -> K r - foo :: forall r. T r - -The body of the forall in foo's type has kind (K r), and -normally it would make no sense to have - forall r. (ty :: K r) -because the kind of the forall would escape the binding -of 'r'. But in this case it's fine because (K r) exapands -to Type, so we explicitly /permit/ the type - forall r. T r - -To accommodate such a type, in typeKind (forall a.ty) we use -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 - * GHC.Tc.Validity.checkEscapingKind -all of which grapple with the same problem. - -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 (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 (typeKind fun) args - -typeKind ty@(ForAllTy {}) - = 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 "typeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - 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 - -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) - where - (tvs, body) = splitForAllTyVars ty - body_kind = tcTypeKind body - - -isPredTy :: HasDebugCallStack => Type -> Bool --- 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 - --- | 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 Type -tcKindRep_maybe kind - | Just (tc, [arg]) <- tcSplitTyConApp_maybe kind -- Note: tcSplit here - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | 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 -tcIsLiftedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> 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 -tcIsBoxedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isBoxedRuntimeRep rep - Nothing -> 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) - -tcReturnsConstraintKind :: 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 - --------------------------- -typeLiteralKind :: TyLit -> Kind -typeLiteralKind (NumTyLit {}) = naturalTy -typeLiteralKind (StrTyLit {}) = typeSymbolKind -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')@, --- but much faster. --- --- __Precondition:__ The type has kind @('TYPE' blah)@ -typeHasFixedRuntimeRep :: Type -> Bool -typeHasFixedRuntimeRep = go - where - go (TyConApp tc _) - | tcHasFixedRuntimeRep tc = True - go (FunTy {}) = True - go (LitTy {}) = True - go (ForAllTy _ ty) = go ty - go ty = isFixedRuntimeRepKind (typeKind ty) - --- | Looking past all pi-types, does the end result have a --- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? --- --- Examples: --- --- * False for @(forall r (a :: TYPE r). String -> a)@ --- * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@ -resultHasFixedRuntimeRep :: Type -> Bool -resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys - -{- ********************************************************************** -* * - 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)@. -isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool -isFixedRuntimeRepKind k - = assertPpr (isLiftedTypeKind k || _is_type) (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, --- concrete type variables, and applications. --- --- See Note [Concrete types] in GHC.Tc.Utils.Concrete. -isConcrete :: Type -> Bool -isConcrete = go - where - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy tv) = isConcreteTyVar tv - go (AppTy ty1 ty2) = go ty1 && go ty2 - go (TyConApp tc tys) - | isConcreteTyCon tc = all go tys - | otherwise = False - go ForAllTy{} = False - go (FunTy _ w t1 t2) = go w - && go (typeKind t1) && go t1 - && go (typeKind t2) && go t2 - go LitTy{} = True - 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) - -{- -%************************************************************************ -%* * - Pretty-printing -%* * -%************************************************************************ - -Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. - --} - --- | Does a 'TyCon' (that is applied to some number of arguments) need to be --- ascribed with an explicit kind signature to resolve ambiguity if rendered as --- a source-syntax type? --- (See @Note [When does a tycon application need an explicit kind signature?]@ --- for a full explanation of what this function checks for.) -tyConAppNeedsKindSig - :: Bool -- ^ Should specified binders count towards injective positions in - -- the kind of the TyCon? (If you're using visible kind - -- applications, then you want True here. - -> TyCon - -> Int -- ^ The number of args the 'TyCon' is applied to. - -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the - -- number of arguments) -tyConAppNeedsKindSig spec_inj_pos tc n_args - | LT <- listLengthCmp tc_binders n_args - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAt n_args tc_binders - result_kind = mkTyConKind remaining_binders tc_res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injective_vars_of_binder dropped_binders - - in not (subVarSet result_vars dropped_vars) - where - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - -- Returns the variables that would be fixed by knowing a TyConBinder. See - -- Note [When does a tycon application need an explicit kind signature?] - -- for a more detailed explanation of what this function does. - injective_vars_of_binder :: TyConBinder -> FV - injective_vars_of_binder (Bndr tv vis) = - case vis of - AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice - (varType tv) - NamedTCB argf | source_of_injectivity argf - -> unitFV tv `unionFV` - injectiveVarsOfType False (varType tv) - _ -> emptyFV - - source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False - -{- -Note [When does a tycon application need an explicit kind signature?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a couple of places in GHC where we convert Core Types into forms that -more closely resemble user-written syntax. These include: - -1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) -2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) - -This conversion presents a challenge: how do we ensure that the resulting type -has enough kind information so as not to be ambiguous? To better motivate this -question, consider the following Core type: - - -- Foo :: Type -> Type - type Foo = Proxy Type - -There is nothing ambiguous about the RHS of Foo in Core. But if we were to, -say, reify it into a TH Type, then it's tempting to just drop the invisible -Type argument and simply return `Proxy`. But now we've lost crucial kind -information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` -or `Proxy Int` or something else! We've inadvertently introduced ambiguity. - -Unlike in other situations in GHC, we can't just turn on --fprint-explicit-kinds, as we need to produce something which has the same -structure as a source-syntax type. Moreover, we can't rely on visible kind -application, since the first kind argument to Proxy is inferred, not specified. -Our solution is to annotate certain tycons with their kinds whenever they -appear in applied form in order to resolve the ambiguity. For instance, we -would reify the RHS of Foo like so: - - type Foo = (Proxy :: Type -> Type) - -We need to devise an algorithm that determines precisely which tycons need -these explicit kind signatures. We certainly don't want to annotate _every_ -tycon with a kind signature, or else we might end up with horribly bloated -types like the following: - - (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) - -We only want to annotate tycons that absolutely require kind signatures in -order to resolve some sort of ambiguity, and nothing more. - -Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type -require a kind signature? It might require it when we need to fill in any of -T's omitted arguments. By "omitted argument", we mean one that is dropped when -reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and -specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the -omitted arguments are only the inferred ones (e.g., in situations where -specified arguments are reified through visible kind application). -Regardless, the key idea is that _some_ arguments are going to be omitted after -reification, and the only mechanism we have at our disposal for filling them in -is through explicit kind signatures. - -What do we mean by "fill in"? Let's consider this small example: - - T :: forall {k}. Type -> (k -> Type) -> k - -Moreover, we have this application of T: - - T @{j} Int aty - -When we reify this type, we omit the inferred argument @{j}. Is it fixed by the -other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then -we'll generate an equality constraint (kappa -> Type) and, assuming we can -solve it, that will fix `kappa`. (Here, `kappa` is the unification variable -that we instantiate `k` with.) - -Therefore, for any application of a tycon T to some arguments, the Question We -Must Answer is: - -* Given the first n arguments of T, do the kinds of the non-omitted arguments - fill in the omitted arguments? - -(This is still a bit hand-wavey, but we'll refine this question incrementally -as we explain more of the machinery underlying this process.) - -Answering this question is precisely the role that the `injectiveVarsOfType` -and `injective_vars_of_binder` functions exist to serve. If an omitted argument -`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing -`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a -bit.) - -More formally, if -`a` is in `injectiveVarsOfType ty` -and S1(ty) ~ S2(ty), -then S1(a) ~ S2(a), -where S1 and S2 are arbitrary substitutions. - -For example, is `F` is a non-injective type family, then - - injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} - -Now that we know what this function does, here is a second attempt at the -Question We Must Answer: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. Do the injective - variables of these binders fill in the remainder of T's kind? - -Alright, we're getting closer. Next, we need to clarify what the injective -variables of a tycon binder are. This the role that the -`injective_vars_of_binder` function serves. Here is what this function does for -each form of tycon binder: - -* Anonymous binders are injective positions. For example, in the promoted data - constructor '(:): - - '(:) :: forall a. a -> [a] -> [a] - - The second and third tyvar binders (of kinds `a` and `[a]`) are both - anonymous, so if we had '(:) 'True '[], then the kinds of 'True and - '[] would contribute to the kind of '(:) 'True '[]. Therefore, - injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. - (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) -* Named binders: - - Inferred binders are never injective positions. For example, in this data - type: - - data Proxy a - Proxy :: forall {k}. k -> Type - - If we had Proxy 'True, then the kind of 'True would not contribute to the - kind of Proxy 'True. Therefore, - injective_vars_of_binder(forall {k}. ...) = {}. - - Required binders are injective positions. For example, in this data type: - - data Wurble k (a :: k) :: k - Wurble :: forall k -> k -> k - - The first tyvar binder (of kind `forall k`) has required visibility, so if - we had Wurble (Maybe a) Nothing, then the kind of Maybe a would - contribute to the kind of Wurble (Maybe a) Nothing. Hence, - injective_vars_of_binder(forall a -> ...) = {a}. - - Specified binders /might/ be injective positions, depending on how you - approach things. Continuing the '(:) example: - - '(:) :: forall a. a -> [a] -> [a] - - Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind - of '(:) 'True '[], since it's not explicitly instantiated by the user. But - if visible kind application is enabled, then this is possible, since the - user can write '(:) @Bool 'True '[]. (In that case, - injective_vars_of_binder(forall a. ...) = {a}.) - - There are some situations where using visible kind application is appropriate - and others where it is not (e.g., TH - reification), so the `injective_vars_of_binder` function is parametrized by - a Bool which decides if specified binders should be counted towards - injective positions or not. - -Now that we've defined injective_vars_of_binder, we can refine the Question We -Must Answer once more: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the remainder of T's kind? - -If the answer to this question is "no", then (T ty_1 ... ty_n) needs an -explicit kind signature, since T's kind has kind variables leftover that -aren't fixed by the non-omitted arguments. - -One last sticking point: what does "the remainder of T's kind" mean? You might -be tempted to think that it corresponds to all of the arguments in the kind of -T that would normally be instantiated by omitted arguments. But this isn't -quite right, strictly speaking. Consider the following (silly) example: - - S :: forall {k}. Type -> Type - -And suppose we have this application of S: - - S Int Bool - -The Int argument would be omitted, and -injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which -might suggest that (S Bool) needs an explicit kind signature. But -(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature -only affects the /result/ of the application, not all of the individual -arguments. So adding a kind signature here won't make a difference. Therefore, -the fourth (and final) iteration of the Question We Must Answer is: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the kind of (T ty_1 ... ty_n)? - -Phew, that was a lot of work! - -How can be sure that this is correct? That is, how can we be sure that in the -event that we leave off a kind annotation, that one could infer the kind of the -tycon application from its arguments? It's essentially a proof by induction: if -we can infer the kinds of every subtree of a type, then the whole tycon -application will have an inferrable kind--unless, of course, the remainder of -the tycon application's kind has uninstantiated kind variables. - -What happens if T is oversaturated? That is, if T's kind has fewer than n -arguments, in the case that the concrete application instantiates a result -kind variable with an arrow kind? If we run out of arguments, we do not attach -a kind annotation. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we choose not to annotate the application of G with -a kind signature. After all, we needn't do this, since that instance would -be reified as: - - type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool - -So the kind of G isn't ambiguous anymore due to the explicit kind annotation -on its argument. See #8953 and test th/T8953. --} - -{- -************************************************************************ -* * - Multiplicities -* * -************************************************************************ - -These functions would prefer to be in GHC.Core.Multiplicity, but -they some are used elsewhere in this module, and wanted to bring -their friends here with them. --} - -unrestricted, linear, tymult :: a -> Scaled a - --- | Scale a payload by Many -unrestricted = Scaled Many - --- | Scale a payload by One -linear = Scaled One - --- | Scale a payload by Many; used for type arguments in core -tymult = Scaled Many - -irrelevantMult :: Scaled a -> a -irrelevantMult = scaledThing - -mkScaled :: Mult -> a -> Scaled a -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 Many :: Mult -pattern Many <- (isManyDataConTy -> True) - where Many = manyDataConTy - -isManyDataConTy :: Mult -> Bool -isManyDataConTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` manyDataConKey -isManyDataConTy _ = False - -isOneDataConTy :: Mult -> Bool -isOneDataConTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` oneDataConKey -isOneDataConTy _ = False - -isLinearType :: Type -> Bool --- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function --- where at least one argument is linear (or otherwise non-unrestricted). We use --- 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 - _ -> False +{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + Type, ForAllTyFlag(..), FunTyFlag(..), + Specificity(..), + KindOrType, PredType, ThetaType, FRRType, + Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder, + Mult, Scaled, + KnotTied, RuntimeRepType, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView, + splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe, + + 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, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + + splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp, + tcSplitTyConApp, tcSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + splitForAllTyCoVars, splitForAllTyVars, + splitForAllReqTyBinders, splitForAllInvisTyBinders, + splitForAllForAllTyBinders, + splitForAllTyCoVar_maybe, splitForAllTyCoVar, + splitForAllTyVar_maybe, splitForAllCoVar_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + getRuntimeArgTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + mkCharLitTy, isCharLitTy, + isLitTy, + + isPredTy, + + getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, + getLevity, levityType_maybe, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitInvisPiTys, splitInvisPiTysN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConForAllTyFlags, appTyForAllTyFlags, + + -- ** Analyzing types + TyCoMapper(..), mapTyCo, mapTyCoX, + TyCoFolder(..), foldTyCo, noView, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + mkForAllTyBinder, mkForAllTyBinders, + mkTyVarBinder, mkTyVarBinders, + tyVarSpecToBinders, + isAnonPiTyBinder, + binderVar, binderVars, binderType, binderFlag, binderFlags, + piTyBinderType, namedPiTyBinder_maybe, + anonPiTyBinderType_maybe, + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder, + isInvisiblePiTyBinder, isNamedPiTyBinder, + tyConBindersPiTyBinders, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, isAtomicTy, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- * Space-saving construction + mkTYPEapp, mkTYPEapp_maybe, + mkCONSTRAINTapp, mkCONSTRAINTapp_maybe, + mkBoxedRepApp_maybe, mkTupleRepApp_maybe, + typeOrConstraintKind, + + -- *** Levity and boxity + sORTKind_maybe, typeTypeOrConstraint, + typeLevity_maybe, tyConIsTYPEorCONSTRAINT, + isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, + isBoxedRuntimeRep, + isLiftedLevity, isUnliftedLevity, + isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, + kindBoxedRepLevity_maybe, + mightBeLiftedType, mightBeUnliftedType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isLevityTy, isLevityVar, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + + -- * Multiplicity + + isMultiplicityTy, isMultiplicityVar, + unrestricted, linear, tymult, + mkScaled, irrelevantMult, scaledSet, + pattern OneTy, pattern ManyTy, + isOneTy, isManyTy, + isLinearType, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, + tcIsLiftedTypeKind, + isConstraintKind, isConstraintLikeKind, returnsConstraintKind, + tcIsBoxedTypeKind, isTypeLikeKind, + + -- ** Common Kind + liftedTypeKind, unliftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + anyFreeVarsOfType, anyFreeVarsOfTypes, + noFreeVarsOfType, + expandTypeSynonyms, + typeSize, occCheckExpand, + + -- ** Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Well-scoped lists of variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + IdSubstEnv, + Subst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptySubst, mkEmptySubst, + + mkSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemSubst, + getTvSubstEnv, + zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptySubst, unionSubst, isEmptyTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, + substThetaUnchecked, substTyWithUnchecked, + substCo, substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + substTyCoBndr, substTyVarToTyVar, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyForAllTyBinder, tidyForAllTyBinders, + + -- * Kinds + isTYPEorCONSTRAINT, + isConcrete, isFixedRuntimeRepKind, + ) where + +import GHC.Prelude + +import GHC.Types.Basic + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs + +-- friends: +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Core.TyCon +import GHC.Builtin.Types.Prim + +import {-# SOURCE #-} GHC.Builtin.Types + ( charTy, naturalTy + , typeSymbolKind, liftedTypeKind, unliftedTypeKind + , 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 + , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo1 + , decomposePiCos, coercionKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo + , topNormaliseNewType_maybe + ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) + +-- others +import GHC.Utils.Misc +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Data.FastString + +import Control.Monad ( guard ) +import GHC.Data.Maybe ( orElse, isJust ) + +-- $type_classification +-- #type_classification# +-- +-- Types are any, but at least one, of: +-- +-- [Boxed] Iff its representation is a pointer to an object on the +-- GC'd heap. Operationally, heap objects can be entered as +-- a means of evaluation. +-- +-- [Lifted] Iff it has bottom as an element: An instance of a +-- lifted type might diverge when evaluated. +-- GHC Haskell's unboxed types are unlifted. +-- An unboxed, but lifted type is not very useful. +-- (Example: A byte-represented type, where evaluating 0xff +-- computes the 12345678th collatz number modulo 0xff.) +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. There are algebraic types that +-- are not lifted types, like unlifted data types or +-- unboxed tuples. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- There are also /unlifted/ data types. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- [Unlifted] Anything that isn't lifted is considered unlifted. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ +-} + +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 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 (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 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 `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. +-- +-- Precondition: the call is saturated or over-saturated; +-- i.e. length tvs <= length arg_tys +expand_syn :: [TyVar] -- ^ the variables bound by the synonym + -> Type -- ^ the RHS of the synonym + -> [Type] -- ^ the type arguments the synonym is instantiated at. + -> Type +{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. + +expand_syn tvs rhs arg_tys + -- No substitution necessary if either tvs or tys is empty + -- This is both more efficient, and steers clear of an infinite + -- loop; see Note [Care using synonyms to compress types] + | null arg_tys = assert (null tvs) rhs + | null tvs = mkAppTys rhs arg_tys + | otherwise = go empty_subst tvs arg_tys + where + empty_subst = mkEmptySubst in_scope + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys + -- The free vars of 'rhs' should all be bound by 'tenv', + -- so we only need the free vars of tys + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + + go subst [] tys + | null tys = rhs' -- Exactly Saturated + | otherwise = mkAppTys rhs' tys + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! + where + rhs' = substTy subst rhs + + go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys + + go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) + -- Under-saturated, precondition failed + +{- Note [Inlining coreView] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very common to have a function + + f :: Type -> ... + f ty | Just ty' <- coreView ty = f ty' + f (TyVarTy ...) = ... + f ... = ... + +If f is not otherwise recursive, the initial call to coreView +causes f to become recursive, which kills the possibility of +inlining. Instead, for non-recursive functions, we prefer to +use coreFullView, which guarantees to unwrap top-level type +synonyms. It can be inlined and is efficient and non-allocating +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) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptySubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ mult arg res) + = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + 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 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) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + 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) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) + = AxiomRuleCo ax (map (go_co subst) cs) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + go_prov _ p@(CorePrepProv _) = p + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrUsing, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- 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 +-- the type @ty = T tys@, where T's unique = key +-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`. +-- Thanks to this fact, we don't have to pattern match on `FunTy` here. +isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type] +isTyConKeyApp_maybe key ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` key + = Just args + | otherwise + = Nothing +{-# INLINE isTyConKeyApp_maybe #-} + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> RuntimeRepType +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | 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) +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType +kindRep_maybe kind + | Just (_, rep) <- sORTKind_maybe kind = Just rep + | otherwise = Nothing + +-- | 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 +-- or TYPE ('BoxedRep 'Lifted) +-- or Type +-- without expanding type synonyms or anything +-- Used only when deciding whether to suppress the ":: *" in +-- (a :: *) when printing kinded type variables +-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr +pickyIsLiftedTypeKind kind + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey + , TyConApp rr_tc rr_args <- arg = case rr_args of + [] -> rr_tc `hasKey` liftedRepTyConKey + [rr_arg] + | rr_tc `hasKey` boxedRepDataConKey + , TyConApp lev [] <- rr_arg + , lev `hasKey` liftedDataConKey -> True + _ -> False + | TyConApp tc [] <- kind + , tc `hasKey` liftedTypeKindTyConKey = True + | otherwise = False + +-- | 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. +kindBoxedRepLevity_maybe :: Type -> Maybe Levity +kindBoxedRepLevity_maybe ty + | Just rep <- kindRep_maybe ty + , isBoxedRuntimeRep rep + = runtimeRepLevity_maybe rep + | otherwise + = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted. +-- +-- 'isLiftedRuntimeRep' is: +-- +-- * True of @LiftedRep :: RuntimeRep@ +-- * False of type variables, type family applications, +-- and of other reps such as @IntRep :: RuntimeRep@. +isLiftedRuntimeRep :: RuntimeRepType -> Bool +isLiftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Lifted + +-- | Check whether a type of kind 'RuntimeRep' is unlifted. +-- +-- * True of definitely unlifted 'RuntimeRep's such as +-- 'UnliftedRep', 'IntRep', 'FloatRep', ... +-- * False of 'LiftedRep', +-- * False for type variables and type family applications. +isUnliftedRuntimeRep :: RuntimeRepType -> Bool +isUnliftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Unlifted + +-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. +-- +-- Checks whether the type is a nullary 'TyCon' application, +-- for a 'TyCon' with the given 'Unique'. +isNullaryTyConKeyApp :: Unique -> Type -> Bool +isNullaryTyConKeyApp key ty + | Just args <- isTyConKeyApp_maybe key ty + = assert (null args) True + | otherwise + = False +{-# INLINE isNullaryTyConKeyApp #-} + +isLiftedLevity :: Type -> Bool +isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey + +isUnliftedLevity :: Type -> Bool +isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey + +-- | Is this the type 'Levity'? +isLevityTy :: Type -> Bool +isLevityTy = isNullaryTyConKeyApp levityTyConKey + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +-- | Is a tyvar of type 'Levity'? +isLevityVar :: TyVar -> Bool +isLevityVar = isLevityTy . tyVarKind + +-- | Is this the type 'Multiplicity'? +isMultiplicityTy :: Type -> Bool +isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey + +-- | Is a tyvar of type 'Multiplicity'? +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 +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for ForAllCo case of mapTyCoX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used +to implement zonking, and it's vital that they get specialised to the TcM +monad and the particular mapper in use. + +Even specialising to the monad alone made a 20% allocation difference +in perf/compiler/T5030. + +See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this +idiom. +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcm_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in "GHC.Tc.TyCl" + } + +{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] +mapTyCo :: Monad m => TyCoMapper () m + -> ( Type -> m Type + , [Type] -> m [Type] + , Coercion -> m Coercion + , [Coercion] -> m[Coercion]) +mapTyCo mapper + = case mapTyCoX mapper of + (go_ty, go_tys, go_co, go_cos) + -> (go_ty (), go_tys (), go_co (), go_cos ()) + +{-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] +mapTyCoX :: Monad m => TyCoMapper env m + -> ( env -> Type -> m Type + , env -> [Type] -> m [Type] + , env -> Coercion -> m Coercion + , env -> [Coercion] -> m[Coercion]) +mapTyCoX (TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon + , tcm_covar = covar + , tcm_hole = cohole }) + = (go_ty, go_tys, go_co, go_cos) + where + go_tys _ [] = return [] + go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty _ ty@(LitTy {}) = return ty + go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty env (CoercionTy co) = CoercionTy <$> go_co env co + + go_ty env ty@(FunTy _ w arg res) + = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res + ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } + + go_ty env ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> go_tys env tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> go_tys env tys + + go_ty env (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; inner' <- go_ty env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + + go_cos _ [] = return [] + go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + + 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 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 + ; mkTyConAppCo r tc' <$> go_cos env cos } + + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppCo r tc <$> go_cos env cos + go_co env (ForAllCo tv kind_co co) + = do { kind_co' <- go_co env kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- go_co env' co + ; return $ mkForAllCo tv' kind_co' co' } + -- See Note [Efficiency for ForAllCo case of mapTyCoX] + + go_prov env (PhantomProv co) = PhantomProv <$> go_co env co + go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@(CorePrepProv _) = return p + + +{- ********************************************************************* +* * + 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 :: HasDebugCallStack => Type -> TyVar +getTyVar ty = case getTyVar_maybe ty of + Just tv -> tv + 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) +getCastedTyVar_maybe ty = case coreFullView ty of + CastTy (TyVarTy tv) co -> Just (tv, co) + TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) + _ -> Nothing + + +{- ********************************************************************* +* * + 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. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +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 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@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +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 = 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) + +------------- +splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any coreView stuff is already done +splitAppTyNoView_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +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! + +splitAppTyNoView_maybe _other = Nothing + +tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type) +-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t) +-- See Note [Decomposing fat arrow c=>t] +tcSplitAppTyNoView_maybe ty + | FunTy { ft_af = af } <- ty + , not (isVisibleFunArg af) -- See Note [Decomposing fat arrow c=>t] + = Nothing + | otherwise + = splitAppTyNoView_maybe ty + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + 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 af w ty1 ty2) args + | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +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 | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy af w ty1 ty2) args + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split ty args = (ty, args) + + +{- ********************************************************************* +* * + LitTy +* * +********************************************************************* -} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty + | LitTy (NumTyLit n) <- coreFullView ty = Just n + | otherwise = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty + | LitTy (StrTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + +mkCharLitTy :: Char -> Type +mkCharLitTy c = LitTy (CharTyLit c) + +-- | Is this a char literal? We also look through type synonyms. +isCharLitTy :: Type -> Maybe Char +isCharLitTy ty + | LitTy (CharTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + + +-- | Is this a type literal (symbol, numeric, or char)? +isLitTy :: Type -> Maybe TyLit +isLitTy ty + | LitTy l <- coreFullView ty = Just l + | otherwise = Nothing + +-- | Is this type a custom user error? +-- If so, give us the kind and the error message. +userTypeError_maybe :: Type -> Maybe Type +userTypeError_maybe t + = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + +{- ********************************************************************* +* * + FunTy +* * +********************************************************************* -} + +{- 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) + + (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when reconstructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +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 :: HasDebugCallStack => 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 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 (FunTyFlag, Mult, Type, Type) +-- ^ Attempts to extract the multiplicity, argument and result types from a type +splitFunTy_maybe ty + | 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 orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: HasDebugCallStack => Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty + | FunTy { ft_res = res } <- coreFullView ty = res + | otherwise = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty + | FunTy { ft_arg = arg } <- coreFullView ty = arg + | otherwise = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg = case coreFullView ty of + FunTy { ft_res = res } -> Just res + + ForAllTy (Bndr tv _) res + -> let empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + _ -> Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: Subst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | Just ty' <- coreView ty + = go subst ty' all_args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = assertPpr (tvs `leLength` arg_tys) pp_stuff $ + assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ + mkAppTys (substTyWith tvs arg_tys_prefix body_ty) + arg_tys_rest + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. +-} + + +{- ********************************************************************* +* * + 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 .. + +-- | 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 { 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 { 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 splitTyConApp_maybe ty of + Just (_, tys) -> Just tys + Nothing -> Nothing + +tyConAppArgs :: HasCallStack => Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (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 = 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 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 +-- +-- 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. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + + +{- ********************************************************************* +* * + CastTy +* * +********************************************************************* -} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty + | CastTy ty' co <- coreFullView ty = Just (ty', co) + | otherwise = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" +mkCastTy :: Type -> Coercion -> Type +mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. +mkCastTy orig_ty co = mk_cast_ty orig_ty co + +-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity, +-- as that can be expensive. +mk_cast_ty :: Type -> Coercion -> Type +mk_cast_ty orig_ty co = go orig_ty + where + go :: Type -> Type + -- See Note [Using coreView in mk_cast_ty] + go ty | Just ty' <- coreView ty = go ty' + + go (CastTy ty co1) + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co) + -- call mkCastTy again for the reflexivity check + + go (ForAllTy (Bndr tv vis) inner_ty) + -- (EQ4) from the Note + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptySubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) + else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) + + go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible + +{- +Note [Using coreView in mk_cast_ty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in +GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance, +consider this example (#19742): + + type EqSameNat = () |> co + useNatEq :: EqSameNat |> sym co + +(Those casts aren't visible in the user-source code, of course; see #19742 for +what the user might write.) + +The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no +nested casts, but if we expand EqSameNat, we see that it doesn't. +And then Bad Things happen. + +The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in +`mk_cast_ty`. +-} + +{- ********************************************************************* +* * + 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 + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + + +{- ********************************************************************* +* * + 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 +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTyMany (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInfForAllTy :: TyVar -> Type -> Type +mkInfForAllTy tv ty = assert (isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = assert (isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = assert (all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +-- | Given a list of type-level vars and the free vars of a result kind, +-- 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 +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( 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. +splitForAllTyCoVars :: Type -> ([TyCoVar], Type) +splitForAllTyCoVars ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs = 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 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 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 '()'. +splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type) +splitForAllReqTyBinders ty = split ty ty [] + where + 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'. +splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type) +splitForAllInvisTyBinders ty = split ty ty [] + where + 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 +isForAllTy ty + | ForAllTy {} <- coreFullView ty = True + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isCoVar tv + = True + + | otherwise = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty = case coreFullView ty of + ForAllTy {} -> True + FunTy {} -> True + _ -> False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty + | FunTy {} <- coreFullView ty = True + | otherwise = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTyCoVar :: Type -> (TyCoVar, Type) +splitForAllTyCoVar ty + | Just answer <- splitForAllTyCoVar_maybe ty = answer + | otherwise = pprPanic "splitForAllTyCoVar" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go (ForAllTy _ res) = go res + go ty | Just ty' <- coreView ty = go ty' + go res = res + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder +splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTyCoVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) + | otherwise = Nothing + +-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder. +splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTyVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isTyVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. +splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type) +splitForAllCoVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isCoVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct +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 (mkScaled w arg) af, res) + _ -> Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (PiTyBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all PiTyBinders to a type, splitting both proper foralls +-- and functions +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 (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) + +-- | Extracts a list of run-time arguments from a function type, +-- looking through newtypes to the right of arrows. +-- +-- Examples: +-- +-- @ +-- newtype Identity a = I a +-- +-- 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 +-- type variable. This function is used only when we really care about the /kinds/ +-- of the returned types, so this is OK. +-- +-- **Warning**: this function can return an infinite list. For example: +-- +-- @ +-- newtype N a = MkN (a -> N a) +-- getRuntimeArgTys (N a) == repeat (a, FTF_T_T) +-- @ +getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)] +getRuntimeArgTys = go + where + go :: Type -> [(Scaled Type, FunTyFlag)] + go (ForAllTy _ res) + = go res + go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) + = (Scaled w arg, af) : go res + go ty + | Just ty' <- coreView ty + = go ty' + | Just (_,ty') <- topNormaliseNewType_maybe ty + = go ty' + | otherwise + = [] + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty)) + +-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. +-- Stops at the first visible binder. +splitInvisPiTys :: Type -> ([PiTyBinder], Type) +splitInvisPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , 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 -> ([PiTyBinder], Type) +-- ^ Same as 'splitInvisPiTys', but stop when +-- - you have found @n@ 'PiTyBinder's, +-- - or you run out of invisible binders +splitInvisPiTysN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , 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. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc 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, ForAllTyFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + 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 +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +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 +-- ('Inferred', 'Specified', or 'Required'). +-- +-- 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 'appTyForAllTyFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +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] -> [ForAllTyFlag] +fun_kind_arg_flags = go emptySubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- 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 | 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. + +-- @isTauTy@ tests if a type has no foralls or (=>) +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +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 { 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 + +isAtomicTy :: Type -> Bool +-- True if the type is just a single token, and can be printed compactly +-- Used when deciding how to lay out type error messages; see the +-- call in GHC.Tc.Errors +isAtomicTy (TyVarTy {}) = True +isAtomicTy (LitTy {}) = True +isAtomicTy (TyConApp _ []) = True + +isAtomicTy ty | isLiftedTypeKind ty = True + -- 'Type' prints compactly as * + -- See GHC.Iface.Type.ppr_kind_type + +isAtomicTy _ = False + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" +isCoVarType :: Type -> Bool + -- ToDo: should we check saturation? +isCoVarType ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +-- This function is here because here is where we have +-- isFamFree and isTauTy +buildSynTyCon name binders res_kind roles rhs + = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful + where + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders || + uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs) + -- NB: This is allowed to be conservative, returning True more often + -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Tries to compute the 'Levity' of the given type. Returns either +-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the +-- type is representation-polymorphic). +-- +-- Panics if the kind does not have the shape @TYPE r@. +typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity +typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) + +-- | Is the given type definitely unlifted? +-- See "Type#type_classification" for what an unlifted type is. +-- +-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- representation polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them +isUnliftedType ty = + case typeLevity_maybe ty of + Just Lifted -> False + Just Unlifted -> True + Nothing -> + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ unlifted or +-- * 'True' if it lifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeLiftedType :: Type -> Bool +mightBeLiftedType = mightBeLifted . typeLevity_maybe + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe + +-- | See "Type#type_classification" for what a boxed type is. +-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- representation polymorphism. +isBoxedType :: Type -> Bool +isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe RuntimeRepType +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, +-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. +-- +-- Returns 'Nothing' if this is not possible. Does not look through type family applications. +getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type +getLevity_maybe ty + | Just rep <- getRuntimeRep_maybe ty + -- Directly matching on TyConApp after expanding type synonyms + -- saves allocations compared to `splitTyConApp_maybe`. See #22254. + -- Given that this is a pretty hot function we make use of the fact + -- and use isTyConKeyApp_maybe instead. + , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep + = Just lev + | otherwise + = Nothing + +-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, +-- or @getLevity (Array# Int) = Unlifted@. +-- +-- Panics if this is not possible. Does not look through type family applications. +getLevity :: HasDebugCallStack => Type -> Type +getLevity ty + | Just lev <- getLevity_maybe ty + = lev + | otherwise + = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Check whether a type is a data family type +isDataFamilyAppType :: Type -> Bool +isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. +-- Panics on representation-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = tvs `disjointVarSet` tyCoVarsOfType ty + | Just (t, ty') <- splitForAllTyCoVar_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, _, _, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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::ki). ty : torc rep + + 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 (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep + -- Surprise 2! + +Note that: +* (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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) expands +to Type, so we explicitly /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +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 + * GHC.Tc.Validity.checkEscapingKind +all of which grapple with the same problem. + +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 { 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] + 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 (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = 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] + 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 + + lifted_kind_from_body -- Implements (FORALL2) + = case sORTKind_maybe body_kind of + Just (ConstraintLike, _) -> constraintKind + Just (TypeLike, _) -> liftedTypeKind + Nothing -> pprPanic "typeKind" (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 + !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 +-- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _) +isPredTy ty = case typeTypeOrConstraint ty of + TypeLike -> False + ConstraintLike -> True + +-- | 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) + +tyConIsTYPEorCONSTRAINT :: TyCon -> Bool +tyConIsTYPEorCONSTRAINT tc + = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey + where + !tc_uniq = tyConUnique tc + +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 + +tcIsLiftedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep? +tcIsLiftedTypeKind kind + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isLiftedRuntimeRep rep + | otherwise + = False + +tcIsBoxedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? +tcIsBoxedTypeKind kind + | 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 @*@. +isTypeLikeKind :: Kind -> Bool +isTypeLikeKind kind + = case sORTKind_maybe kind of + Just (TypeLike, _) -> True + _ -> False + +returnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +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 +typeLiteralKind (NumTyLit {}) = naturalTy +typeLiteralKind (StrTyLit {}) = typeSymbolKind +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` +-- but much faster. +-- +-- __Precondition:__ The type has kind @('TYPE' blah)@ +typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool +typeHasFixedRuntimeRep = go + where + go (TyConApp tc _) + | tcHasFixedRuntimeRep tc = True + go (FunTy {}) = True + go (LitTy {}) = True + go (ForAllTy _ ty) = go ty + go ty = isFixedRuntimeRepKind (typeKind ty) + +argsHaveFixedRuntimeRep :: Type -> Bool +-- ^ True if the argument types of this function type +-- all have a fixed-runtime-rep +argsHaveFixedRuntimeRep ty + = all ok bndrs + where + ok :: PiTyBinder -> Bool + ok (Anon ty _) = typeHasFixedRuntimeRep (scaledThing ty) + ok _ = True + + bndrs :: [PiTyBinder] + (bndrs, _) = splitPiTys ty + +-- | Checks that a kind of the form 'Type', 'Constraint' +-- or @'TYPE r@ is concrete. See 'isConcrete'. +-- +-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah` +isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool +isFixedRuntimeRepKind k + = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $ + -- the isLiftedTypeKind check is necessary b/c of Constraint + isConcrete k + +-- | Tests whether the given type is concrete, i.e. it +-- whether it consists only of concrete type constructors, +-- concrete type variables, and applications. +-- +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete. +isConcrete :: Type -> Bool +isConcrete = go + where + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy tv) = isConcreteTyVar tv + go (AppTy ty1 ty2) = go ty1 && go ty2 + go (TyConApp tc tys) + | isConcreteTyCon tc = all go tys + | otherwise = False + go ForAllTy{} = False + go (FunTy _ w t1 t2) = go w + && go (typeKind t1) && go t1 + && go (typeKind t2) && go t2 + go LitTy{} = True + go CastTy{} = False + go CoercionTy{} = False + + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB af | isVisibleFunArg af + -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) +2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the +omitted arguments are only the inferred ones (e.g., in situations where +specified arguments are reified through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavy, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parameterized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These functions would prefer to be in GHC.Core.Multiplicity, but +they some are used elsewhere in this module, and wanted to bring +their friends here with them. +-} + +unrestricted, linear, tymult :: a -> Scaled a + +-- | Scale a payload by Many +unrestricted = Scaled ManyTy + +-- | Scale a payload by One +linear = Scaled OneTy + +-- | Scale a payload by Many; used for type arguments in core +tymult = Scaled ManyTy + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +pattern OneTy :: Mult +pattern OneTy <- (isOneTy -> True) + where OneTy = oneDataConTy + +pattern ManyTy :: Mult +pattern ManyTy <- (isManyTy -> True) + where ManyTy = manyDataConTy + +isManyTy :: Mult -> Bool +isManyTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` manyDataConKey +isManyTy _ = False + +isOneTy :: Mult -> Bool +isOneTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` oneDataConKey +isOneTy _ = False + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- 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 _ 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) + | tc `hasKey` liftedRepTyConKey = assert (null args) $ + Just constraintKind -- CONSTRAINT LiftedRep +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 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -6,27 +6,33 @@ import {-# SOURCE #-} GHC.Core.TyCon 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 :: Type -> 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/Unfold.hs b/compiler/GHC/Core/Unfold.hs --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -47,10 +47,10 @@ import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info -import GHC.Types.Basic ( Arity ) +import GHC.Types.RepType ( isZeroBitTy ) +import GHC.Types.Basic ( Arity, RecFlag(..) ) import GHC.Core.Type import GHC.Builtin.Names -import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag import GHC.Utils.Logger import GHC.Utils.Misc @@ -431,7 +431,7 @@ size_up (Type _) = sizeZero -- Types cost nothing size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isRealWorldId f = sizeZero + size_up (Var f) | isZeroBitId f = sizeZero -- Make sure we get constructor discounts even -- on nullary constructors | otherwise = size_up_call f [] 0 @@ -439,10 +439,10 @@ size_up (App fun arg) | isTyCoArg arg = size_up fun | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) size_up (Lam b e) - | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) @@ -528,9 +528,9 @@ is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of - FCallId fc -> not (isSafeForeignCall fc) - PrimOpId op -> not (primOpOutOfLine op) - _other -> False + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op _ -> not (primOpOutOfLine op) + _other -> False | otherwise = False @@ -546,7 +546,7 @@ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args voids | isTyCoArg arg = size_up_app fun args voids - | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) voids size_up_app (Var fun) args voids = size_up_call fun args voids @@ -564,7 +564,7 @@ = case idDetails fun of FCallId _ -> sizeN (callSize (length val_args) voids) DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op -> primOpSize op (length val_args) + PrimOpId op _ -> primOpSize op (length val_args) ClassOpId _ -> classOpSize opts top_args val_args _ -> funSize opts top_args fun (length val_args) voids @@ -580,10 +580,9 @@ ------------ -- Cost to allocate binding with given binder size_up_alloc bndr - | isTyVar bndr -- Doesn't exist at runtime - || isJoinId bndr -- Not allocated at all - || isUnliftedType (idType bndr) -- Doesn't live in heap - -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder) + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || not (isBoxedType (idType bndr)) -- Doesn't live in heap = 0 | otherwise = 10 @@ -611,12 +610,14 @@ (xs `unionBags` ys) d2 -- Ignore d1 - isRealWorldId id = idType id `eqType` realWorldStatePrimTy + -- don't count expressions such as State# RealWorld + -- exclude join points, because they can be rep-polymorphic + -- and typePrimRep will crash + isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id) - -- an expression of type State# RealWorld must be a variable - isRealWorldExpr (Var id) = isRealWorldId id - isRealWorldExpr (Tick _ e) = isRealWorldExpr e - isRealWorldExpr _ = False + isZeroBitExpr (Var id) = isZeroBitId id + isZeroBitExpr (Tick _ e) = isZeroBitExpr e + isZeroBitExpr _ = False -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -734,7 +735,7 @@ charge 10 for each case alternative (see size_up_alt). If we give a bigger discount (say 20) in conSize, we'll make the case expression cost *nothing*, and that can make a huge case tree cost nothing. This -leads to massive, sometimes exponenial inlinings (#18282). In short, +leads to massive, sometimes exponential inlinings (#18282). In short, don't give a discount that give a negative size to a sub-expression! Historical note 2: Much longer ago, Simon M tried a MUCH bigger @@ -1001,7 +1002,7 @@ data CallCtxt = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | RhsCtxt RecFlag -- Rhs of a let-binding; see Note [RHS of lets] | DiscArgCtxt -- Argument of a function with non-zero arg discount | RuleArgCtxt -- We are somewhere in the argument of a function with rules @@ -1016,7 +1017,7 @@ ppr CaseCtxt = text "CaseCtxt" ppr ValAppCtxt = text "ValAppCtxt" ppr BoringCtxt = text "BoringCtxt" - ppr RhsCtxt = text "RhsCtxt" + ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" @@ -1170,7 +1171,7 @@ UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts) - -- See Note [INLINE for small functions (3)] + -- See Note [INLINE for small functions] (3) -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template) | otherwise -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing @@ -1219,7 +1220,7 @@ , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] ctx = log_default_dump_context (logFlags logger) - str = "Considering inlining: " ++ renderWithContext ctx (ppr id) + str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id) n_val_args = length arg_infos -- some_benefit is used when the RHS is small enough @@ -1249,21 +1250,17 @@ = case cont_info of CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] ValAppCtxt -> True -- Note [Cast then apply] - RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + RuleArgCtxt -> uf_arity > 0 -- See Note [RHS of lets] DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - RhsCtxt -> uf_arity > 0 -- + RhsCtxt NonRecursive + -> uf_arity > 0 -- See Note [RHS of lets] _other -> False -- See Note [Nested functions] -{- -Note [Unfold into lazy contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Merged into Note [RHS of lets]. - -Note [RHS of lets] -~~~~~~~~~~~~~~~~~~ +{- Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~ When the call is the argument of a function with a RULE, or the RHS of a let, -we are a little bit keener to inline. For example +we are a little bit keener to inline (in tryUnfolding). For example f y = (y,y,y) g y = let x = f y in ...(case x of (a,b,c) -> ...) ... We'd inline 'f' if the call was in a case context, and it kind-of-is, @@ -1272,8 +1269,12 @@ could be expensive whereas x = case v of (a,b) -> a is patently cheap and may allow more eta expansion. -So we treat the RHS of a let as not-totally-boring. +So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a +/non-recursive/ let as not-totally-boring. A /recursive/ let isn't +going be inlined so there is much less point. Hence the (only reason +for the) RecFlag in RhsCtxt + Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When a call is not saturated, we *still* inline if one of the @@ -1313,20 +1314,6 @@ Make sure that x does not inline unconditionally! Lest we get extra allocation. -Note [Inlining an InlineRule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InlineRules is used for - (a) programmer INLINE pragmas - (b) inlinings from worker/wrapper - -For (a) the RHS may be large, and our contract is that we *only* inline -when the function is applied to all the arguments on the LHS of the -source-code defn. (The uf_arity in the rule.) - -However for worker/wrapper it may be worth inlining even if the -arity is not satisfied (as we do in the CoreUnfolding case) so we don't -require saturation. - Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ At one time we treated a call of a non-top-level function as @@ -1367,8 +1354,11 @@ for the RHS of a 'let', we only profit from the inlining if we get a CONLIKE thing (modulo lets). -Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~ which appears below +Note [Lone variables] +~~~~~~~~~~~~~~~~~~~~~ +See also Note [Interaction of exprIsWorkFree and lone variables] +which appears below + The "lone-variable" case is important. I spent ages messing about with unsatisfactory variants, but this is nice. The idea is that if a variable appears all alone @@ -1405,8 +1395,8 @@ However, watch out: * Consider this: - foo = _inline_ (\n. [n]) - bar = _inline_ (foo 20) + foo = \n. [n]) {-# INLINE foo #-} + bar = foo 20 {-# INLINE bar #-} baz = \n. case bar of { (m:_) -> m + n } Here we really want to inline 'bar' so that we can inline 'foo' and the whole thing unravels as it should obviously do. This is @@ -1414,9 +1404,9 @@ structure rather than a list. So the non-inlining of lone_variables should only apply if the - unfolding is regarded as cheap; because that is when exprIsConApp_maybe - looks through the unfolding. Hence the "&& is_wf" in the - InlineRule branch. + unfolding is regarded as expandable; because that is when + exprIsConApp_maybe looks through the unfolding. Hence the "&& + is_exp" in the CaseCtxt branch of interesting_call * Even a type application or coercion isn't a lone variable. Consider diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -9,13 +9,12 @@ , mkFinalUnfolding' , mkSimpleUnfolding , mkWorkerUnfolding - , mkInlineUnfolding - , mkInlineUnfoldingWithArity + , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity , mkInlinableUnfolding , mkWrapperUnfolding - , mkCompulsoryUnfolding - , mkCompulsoryUnfolding' + , mkCompulsoryUnfolding, mkCompulsoryUnfolding' , mkDFunUnfolding + , mkDataConUnfolding , specUnfolding , certainlyWillInline ) @@ -44,10 +43,10 @@ -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding +mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding -- "Final" in the sense that this is a GlobalId that will not be further -- simplified; so the unfolding should be occurrence-analysed -mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr +mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing -- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need -- to pass a precomputed 'UnfoldingCache' @@ -60,15 +59,14 @@ (isDeadEndSig strict_sig) expr --- | Used for things that absolutely must be unfolded -mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr) +-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first +mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding +mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) --- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed --- on the unfolding. -mkCompulsoryUnfolding' :: CoreExpr -> Unfolding -mkCompulsoryUnfolding' expr - = mkCoreUnfolding InlineCompulsory True +-- | Used for things that absolutely must be unfolded +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr + = mkCoreUnfolding CompulsorySrc True expr Nothing (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) @@ -81,7 +79,7 @@ mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs - = mkUnfolding opts InlineRhs False False rhs Nothing + = mkUnfolding opts VanillaSrc False False rhs Nothing mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops @@ -90,11 +88,21 @@ , df_args = map occurAnalyseExpr ops } -- See Note [Occurrence analysis of unfoldings] +mkDataConUnfolding :: CoreExpr -> Unfolding +-- Used for non-newtype data constructors with non-trivial wrappers +mkDataConUnfolding expr + = mkCoreUnfolding StableSystemSrc True expr Nothing guide + -- No need to simplify the expression + where + guide = UnfWhen { ug_arity = manifestArity expr + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = False } + mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split -- after demand/CPR analysis mkWrapperUnfolding opts expr arity - = mkCoreUnfolding InlineStable True + = mkCoreUnfolding StableSystemSrc True (simpleOptExpr opts expr) Nothing (UnfWhen { ug_arity = arity , ug_unsat_ok = unSaturatedOk @@ -113,13 +121,13 @@ mkWorkerUnfolding _ _ _ = noUnfolding --- | Make an unfolding that may be used unsaturated +-- | Make an INLINE unfolding that may be used unsaturated -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its -- manifest arity (the number of outer lambdas applications will -- resolve before doing any work). -mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkInlineUnfolding opts expr - = mkCoreUnfolding InlineStable +mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlineUnfoldingNoArity opts src expr + = mkCoreUnfolding src True -- Note [Top-level flag on inline rules] expr' Nothing guide where @@ -129,11 +137,11 @@ , ug_boring_ok = boring_ok } boring_ok = inlineBoringOk expr' --- | Make an unfolding that will be used once the RHS has been saturated +-- | Make an INLINE unfolding that will be used once the RHS has been saturated -- to the given arity. -mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding -mkInlineUnfoldingWithArity arity opts expr - = mkCoreUnfolding InlineStable +mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity opts src arity expr + = mkCoreUnfolding src True -- Note [Top-level flag on inline rules] expr' Nothing guide where @@ -146,9 +154,9 @@ boring_ok | arity == 0 = True | otherwise = inlineBoringOk expr' -mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkInlinableUnfolding opts expr - = mkUnfolding (so_uf_opts opts) InlineStable False False expr' Nothing +mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlinableUnfolding opts src expr + = mkUnfolding (so_uf_opts opts) src False False expr' Nothing where expr' = simpleOptExpr opts expr @@ -164,7 +172,7 @@ df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) = assertPpr (rule_lhs_args `equalLength` old_bndrs) (ppr df $$ ppr rule_lhs_args) $ - -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise + -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise mkDFunUnfolding spec_bndrs con (map spec_arg args) -- For DFunUnfoldings we transform -- \obs. MkD ... @@ -203,25 +211,41 @@ must do so too! Otherwise we lose the magic rules that make it interact with ClassOps -* There is a bit of hack for INLINABLE functions: - f :: Ord a => .... - f = - {- INLINABLE f #-} - Now if we specialise f, should the specialised version still have - an INLINABLE pragma? If it does, we'll capture a specialised copy - of as its unfolding, and that probably won't inline. But - if we don't, the specialised version of might be small - enough to inline at a call site. This happens with Control.Monad.liftM3, - and can cause a lot more allocation as a result (nofib n-body shows this). +* For a /stable/ CoreUnfolding, we specialise the unfolding, no matter + how big, iff it has UnfWhen guidance. This happens for INLINE + functions, and for wrappers. For these, it would be very odd if a + function marked INLINE was specialised (because of some local use), + and then forever after (including importing modules) the specialised + version wasn't INLINEd! After all, the programmer said INLINE. - Moreover, keeping the INLINABLE thing isn't much help, because +* However, for a stable CoreUnfolding with guidance UnfoldIfGoodArgs, + which arises from INLINABLE functions, we drop the unfolding. + See #4874 for persuasive examples. Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int f xs = letrec f' = ...f'... in f' + + Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } + + and we clearly want to inline f_spec at call sites. But if we still + have the big, un-optimised of f (albeit specialised) captured in the + stable unfolding for f_spec, we won't get that optimisation. + + This happens with Control.Monad.liftM3, and can cause a lot more + allocation as a result (nofib n-body shows this). + + Moreover, keeping the stable unfolding isn't much help, because the specialised function (probably) isn't overloaded any more. - Conclusion: drop the INLINEALE pragma. In practice what this means is: - if a stable unfolding has UnfoldingGuidance of UnfWhen, - we keep it (so the specialised thing too will always inline) - if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs - (which arises from INLINABLE), we discard it + TL;DR: we simply drop the stable unfolding when specialising. It's not + really a complete solution; ignoring specialisation for now, INLINABLE + functions don't get properly strictness analysed, for example. + Moreover, it means that the specialised function has an INLINEABLE + pragma, but no stable unfolding. But it works well for examples + involving specialisation, which is the dominant use of INLINABLE. Note [Honour INLINE on 0-ary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -310,6 +334,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr precomputed_cache guidance = CoreUnfolding { uf_tmpl = cache `seq` occurAnalyseExpr expr @@ -354,15 +379,13 @@ UnfIfGoodArgs { ug_size = size, ug_args = args } -> do_cunf size args src' tmpl' where - src' = -- Do not change InlineCompulsory! - case src of - InlineCompulsory -> InlineCompulsory - _ -> InlineStable - tmpl' = -- Do not overwrite stable unfoldings! - case src of - InlineRhs -> occurAnalyseExpr rhs' - _ -> uf_tmpl fn_unf + src' | isCompulsorySource src = src -- Do not change InlineCompulsory! + | otherwise = StableSystemSrc + tmpl' | isStableSource src = uf_tmpl fn_unf + | otherwise = occurAnalyseExpr rhs' + -- Do not overwrite stable unfoldings! + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense -- to do so, and even if it is currently a -- loop breaker, it may not be later @@ -430,12 +453,12 @@ Core expressions retained in unfoldings is one of biggest uses of memory when compiling a program. Therefore we have to be careful about retaining copies of old or redundant -templates (see !6202 for a particularlly bad case). +templates (see !6202 for a particularly bad case). With that in mind we want to maintain the invariant that each unfolding only references a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding. -* The template of the unfolding is the result of performing occurence analysis +* The template of the unfolding is the result of performing occurrence analysis (Note [Occurrence analysis of unfoldings]) * Predicates are applied to the unanalysed expression @@ -456,7 +479,7 @@ 1. Perform the predicates on the analysed expression. 2. Force the predicates to remove retainer to the old expression if we force the template. -Option 1 is bad because occurence analysis is expensive and destroys any sharing of the unfolding +Option 1 is bad because occurrence analysis is expensive and destroys any sharing of the unfolding with the actual program. (Testing this approach showed peak 25G memory usage) Therefore we got for Option 2 which performs a little more work but compensates by diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE DeriveFunctor #-} @@ -10,21 +10,19 @@ 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,20 +35,18 @@ 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 ) -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, fvVarSet, fvVarList ) +import GHC.Utils.FV( FV, fvVarList ) import GHC.Utils.Misc import GHC.Data.Pair 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 import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -58,8 +54,6 @@ import Control.Monad import qualified Data.Semigroup as S -import GHC.Builtin.Names (constraintKindTyConKey, liftedTypeKindTyConKey) - {- Unification is much tricker than you might think. @@ -134,27 +128,27 @@ -- always used on top-level types, so we can bind any of the -- free variables of the LHS. -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy :: Type -> Type -> Maybe Subst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] -tcMatchTyX_BM :: BindFun -> TCvSubst - -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM :: BindFun -> Subst + -> Type -> Type -> Maybe Subst tcMatchTyX_BM bind_me subst ty1 ty2 = tc_match_tys_x bind_me False subst [ty1] [ty2] -- | Like 'tcMatchTy', but allows the kinds of the types to differ, -- and thus matches them as well. -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi :: Type -> Type -> Maybe Subst tcMatchTyKi ty1 ty2 = tc_match_tys alwaysBindFun True [ty1] [ty2] -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyX :: TCvSubst -- ^ Substitution to extend +tcMatchTyX :: Subst -- ^ Substitution to extend -> Type -- ^ Template -> Type -- ^ Target - -> Maybe TCvSubst + -> Maybe Subst tcMatchTyX subst ty1 ty2 = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2] @@ -162,7 +156,7 @@ -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTys :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ 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 @@ -171,25 +165,25 @@ -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKis :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTyKis tys1 tys2 = tc_match_tys alwaysBindFun True tys1 tys2 -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTysX :: TCvSubst -- ^ Substitution to extend +tcMatchTysX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2 = tc_match_tys_x alwaysBindFun False subst tys1 tys2 -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend +tcMatchTyKisX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 = tc_match_tys_x alwaysBindFun True subst tys1 tys2 @@ -198,27 +192,27 @@ -> Bool -- ^ match kinds? -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2 where in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' tc_match_tys_x :: BindFun -> Bool -- ^ match kinds? - -> TCvSubst + -> Subst -> [Type] -> [Type] - -> Maybe TCvSubst -tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + -> Maybe Subst +tc_match_tys_x bind_me match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 = case tc_unify_tys bind_me False -- Matching, not unifying False -- Not an injectivity check match_kis (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of Unifiable (tv_env', cv_env') - -> Just $ TCvSubst in_scope tv_env' cv_env' + -> Just $ Subst in_scope id_env tv_env' cv_env' _ -> Nothing -- | This one is called from the expression matcher, @@ -255,62 +249,6 @@ 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 - - {- ************************************************************************ * * @@ -352,13 +290,12 @@ -- 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 {- ************************************************************************ * * @@ -461,12 +398,12 @@ -- | Simple unification of two types; all type variables are bindable -- Precondition: the kinds are already equal tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst + -> Maybe Subst -- A regular one-shot (idempotent) substitution tcUnifyTy t1 t2 = tcUnifyTys alwaysBindFun [t1] [t2] -- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi :: Type -> Type -> Maybe Subst tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying @@ -475,32 +412,33 @@ tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; -- False <=> do one-way matching. -- See end of sec 5.2 from the paper - -> Type -> Type -> Maybe TCvSubst + -> InScopeSet -- Should include the free tyvars of both Type args + -> Type -> Type -- Types to unify + -> Maybe Subst -- This algorithm is an implementation of the "Algorithm U" presented in -- the paper "Injective type families for Haskell", Figures 2 and 3. -- The code is incorporated with the standard unifier for convenience, but -- its operation should match the specification in the paper. -tcUnifyTyWithTFs twoWay t1 t2 +tcUnifyTyWithTFs twoWay in_scope t1 t2 = case tc_unify_tys alwaysBindFun twoWay True False rn_env emptyTvSubstEnv emptyCvSubstEnv [t1] [t2] of - Unifiable (subst, _) -> Just $ maybe_fix subst - MaybeApart _reason (subst, _) -> Just $ maybe_fix subst + Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst + MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst -- we want to *succeed* in questionable cases. This is a -- pre-unification algorithm. SurelyApart -> Nothing where - in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] rn_env = mkRnEnv2 in_scope - maybe_fix | twoWay = niFixTCvSubst + maybe_fix | twoWay = niFixSubst in_scope | otherwise = mkTvSubst in_scope -- when matching, don't confuse -- domain with range ----------------- tcUnifyTys :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst -- ^ A regular one-shot (idempotent) substitution -- that unifies the erased types. See comments -- for 'tcUnifyTysFG' @@ -515,7 +453,7 @@ -- | Like 'tcUnifyTys' but also unifies the kinds tcUnifyTyKis :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tcUnifyTyKis bind_fn tys1 tys2 = case tcUnifyTyKisFG bind_fn tys1 tys2 of Unifiable result -> Just result @@ -523,7 +461,7 @@ -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TCvSubst +type UnifyResult = UnifyResultM Subst -- | See Note [Unification result] data UnifyResultM a = Unifiable a -- the subst that unifies the types @@ -538,11 +476,14 @@ -- 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" ppr MARInfinite = text "MARInfinite" @@ -588,13 +529,13 @@ -> [Type] -> [Type] -> UnifyResult tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2 - ; return $ niFixTCvSubst env } + ; return $ niFixSubst in_scope env } where - vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - env = mkRnEnv2 $ mkInScopeSet vars + in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + rn_env = mkRnEnv2 in_scope -- | This function is actually the one to call the unifier -- a little -- too general for outside clients, though. @@ -727,13 +668,13 @@ shadowing. -} -niFixTCvSubst :: TvSubstEnv -> TCvSubst +niFixSubst :: InScopeSet -> TvSubstEnv -> Subst -- Find the idempotent fixed point of the non-idempotent substitution -- This is surprisingly tricky: -- see Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? -niFixTCvSubst tenv - | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) | otherwise = subst where range_fvs :: FV @@ -750,12 +691,11 @@ free_tvs = scopedSort (filterOut in_domain range_tvs) -- See Note [Finding the substitution fixpoint], Step 6 - init_in_scope = mkInScopeSet (fvVarSet range_fvs) subst = foldl' add_free_tv - (mkTvSubst init_in_scope tenv) + (mkTvSubst in_scope tenv) free_tvs - add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv :: Subst -> TyVar -> Subst add_free_tv subst tv = extendTvSubst subst tv (mkTyVarTy tv') where @@ -944,10 +884,18 @@ 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 @@ -1046,59 +994,6 @@ (legitimately) have different numbers of arguments. They are surelyApart, so we can report that without looking any further (see #15704). - -Note [Unifying type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unifying type applications is quite subtle, as we found -in #23134 and #22647, when type families are involved. - -Suppose - type family F a :: Type -> Type - type family G k :: k = r | r -> k - -and consider these examples: - -* F Int ~ F Char, where F is injective - Since F is injective, we can reduce this to Int ~ Char, - therefore SurelyApart. - -* F Int ~ F Char, where F is not injective - Without injectivity, return MaybeApart. - -* G Type ~ G (Type -> Type) Int - Even though G is injective and the arguments to G are different, - we cannot deduce apartness because the RHS is oversaturated. - For example, G might be defined as - G Type = Maybe Int - G (Type -> Type) = Maybe - So we return MaybeApart. - -* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char) - F Int Bool ~ Maybe a -- MaybeApart - F Int Bool ~ a b -- MaybeApart - F Int Bool ~ Char -> Bool -- MaybeApart - An oversaturated type family can match an application, - whether it's a TyConApp, AppTy or FunTy. Decompose. - -* F Int ~ a b - We cannot decompose a saturated, or under-saturated - type family application. We return MaybeApart. - -To handle all those conditions, unify_ty goes through -the following checks in sequence, where Fn is a type family -of arity n: - -* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n - A saturated application. - Here we can unify arguments in which Fn is injective. -* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n - A saturated type family can match anything - we return MaybeApart. -* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n - An oversaturated type family can be decomposed. -* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n - If we couldn't decompose in the previous step, we return SurelyApart. - -Afterwards, the rest of the code doesn't have to worry about type families. -} -------------- unify_ty: the main workhorse ----------- @@ -1111,6 +1006,8 @@ -> 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 @@ -1119,19 +1016,10 @@ | 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)] @@ -1147,89 +1035,70 @@ = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco - -- Handle non-oversaturated type families first - -- See Note [Unifying type applications] - -- - -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T - -- Note that both sides must not be oversaturated - | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1 - , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2 + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 , tc1 == tc2 - = do { let inj = case tyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 - | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application - = maybeApart MARTypeFamily -- behaves like a type variable; might match + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } - | Just _ <- isSatTyFamApp mb_tc_app2 -- (C2) A (not-over-saturated) type-family application - -- behaves like a type variable; might unify - -- but doesn't match (as in the TyVarTy case) - = if um_unif env then maybeApart MARTypeFamily else surelyApart + | isTyFamApp mb_tc_app1 -- A (not-over-saturated) type-family application + = maybeApart MARTypeFamily -- behaves like a type variable; might match - -- Handle oversaturated type families. - -- - -- They can match an application (TyConApp/FunTy/AppTy), this is handled - -- the same way as in the AppTy case below. - -- - -- If there is no application, an oversaturated type family can only - -- match a type variable or a saturated type family, - -- both of which we handled earlier. So we can say surelyApart. - | Just (tc1, _) <- mb_tc_app1 - , isTypeFamilyTyCon tc1 - = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) + | isTyFamApp mb_tc_app2 -- A (not-over-saturated) type-family application + , um_unif env -- behaves like a type variable; might unify + = maybeApart MARTypeFamily - | Just (tc2, _) <- mb_tc_app2 - , isTypeFamilyTyCon tc2 - = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) + -- 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] - -- At this point, neither tc1 nor tc2 can be a type family. - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 - = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1) - ; unify_tys env tys1 tys2 - } + -- 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 @@ -1244,7 +1113,7 @@ 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 @@ -1261,8 +1130,8 @@ 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 @@ -1276,6 +1145,7 @@ ; 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 @@ -1290,16 +1160,16 @@ -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] -isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type]) --- Return the argument if we have a saturated type family application +isTyFamApp :: Maybe (TyCon, [Type]) -> Bool +-- True if we have a saturated or under-saturated type family application -- If it is /over/ saturated then we return False. E.g. -- unify_ty (F a b) (c d) where F has arity 1 -- we definitely want to decompose that type application! (#22647) -isSatTyFamApp tapp@(Just (tc, tys)) - | isTypeFamilyTyCon tc +isTyFamApp (Just (tc, tys)) + = not (isGenerativeTyCon tc Nominal) -- Type family-ish && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated - = tapp -isSatTyFamApp _ = Nothing +isTyFamApp Nothing + = False --------------------------------- uVar :: UMEnv @@ -1345,8 +1215,7 @@ -- 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 @@ -1520,11 +1389,11 @@ getCvSubstEnv :: UM CvSubstEnv getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) -getSubst :: UMEnv -> UM TCvSubst +getSubst :: UMEnv -> UM Subst getSubst env = do { tv_env <- getTvSubstEnv ; cv_env <- getCvSubstEnv ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> @@ -1614,7 +1483,7 @@ = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co ; cenv2 <- ty_co_match menv cenv1 ty co (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + ; return (LC (mkEmptySubst in_scope) cenv2) } where menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) @@ -1640,8 +1509,6 @@ -- 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 @@ -1662,7 +1529,7 @@ ty_co_match menv subst ty co lkco rkco | CastTy ty' co' <- ty -- See Note [Matching in the presence of casts (1)] - = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + = let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv)) substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' in @@ -1700,25 +1567,25 @@ | 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) lkco rkco @@ -1740,9 +1607,9 @@ -- 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 @@ -1772,7 +1639,6 @@ 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 @@ -1783,16 +1649,13 @@ -> 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) @@ -1800,34 +1663,32 @@ = 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 (tyConRolesX r tc) tys)) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys)) Just (ForAllTy (Bndr tv _) ty, r) -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) -- NB: NoRefl variant. Otherwise, we get a loop! @@ -1952,7 +1813,7 @@ variables outside of their scope: note that its domain is the *unrenamed* variables. This means that the substitution gets "pushed down" (like a reader monad) while the in-scope set gets threaded (like a state monad). - Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + Because a Subst contains its own in-scope set, we don't carry a Subst; instead, we just carry a TvSubstEnv down, tying it to the InScopeSet traveling separately as necessary. @@ -2124,7 +1985,7 @@ in (env'', ty') where arity = tyConArity fam_tc - tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + tcv_subst = Subst (fe_in_scope env) emptyIdSubstEnv tv_subst emptyVarEnv (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $ splitAt arity fam_args -- Apply the substitution before looking up an application in the @@ -2150,3 +2011,4 @@ = 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 --- a/compiler/GHC/Core/UsageEnv.hs +++ b/compiler/GHC/Core/UsageEnv.hs @@ -46,10 +46,10 @@ 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 @@ 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 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,7 +23,7 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, @@ -31,14 +31,10 @@ isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, - altsAreExhaustive, + altsAreExhaustive, etaExpansionTick, -- * Equality - cheapEqExpr, cheapEqExpr', eqExpr, - diffBinds, - - -- * Lambdas and eta reduction - tryEtaReduce, canEtaReduceToArity, + cheapEqExpr, cheapEqExpr', diffBinds, -- * Manipulating data constructors and types exprToType, @@ -50,6 +46,9 @@ stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicksE, stripTicksT, + -- * InScopeSet things which work over CoreBinds + mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs, + -- * StaticPtr collectMakeStaticArgs, @@ -71,22 +70,18 @@ import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( exprFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.FamInstEnv -import GHC.Core.Predicate -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 import GHC.Core.Multiplicity -import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) import GHC.Builtin.PrimOps -import GHC.Data.Graph.UnVar import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Var.Env @@ -100,11 +95,11 @@ ) import GHC.Types.Unique import GHC.Types.Unique.Set +import GHC.Types.Demand import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList ) -import GHC.Data.Pair import GHC.Data.OrdList import GHC.Utils.Constants (debugIsOn) @@ -112,7 +107,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Trace import Data.ByteString ( ByteString ) import Data.Function ( on ) @@ -120,7 +114,6 @@ import Data.Ord ( comparing ) import qualified Data.Set as Set import GHC.Types.RepType (isZeroBitTy) -import GHC.Types.Demand (isStrictDmd, isAbsDmd, isDeadEndAppSig) {- ************************************************************************ @@ -142,7 +135,7 @@ , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) | otherwise = exprType body exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Cast _ co) = coercionRKind co exprType (Tick _ e) = exprType e exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) @@ -176,26 +169,15 @@ 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 {- @@ -245,7 +227,7 @@ 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) @@ -282,7 +264,7 @@ -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions -mkCast :: CoreExpr -> CoercionR -> CoreExpr +mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr mkCast e co | assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast" @@ -335,6 +317,11 @@ -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- mkTick' handles floating of ticks *into* the expression. + -- In this function, `top` is applied after adding the tick, and `rest` before. + -- This will result in applications that look like (top $ Tick t $ rest expr). + -- If we want to push the tick deeper, we pre-compose `top` with a function + -- adding the tick. mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) -> CoreExpr -- current expression @@ -499,7 +486,7 @@ ************************************************************************ -} -bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr -- ^ @bindNonRec x r b@ produces either: -- -- > let x = r in b @@ -525,8 +512,8 @@ case_bind = mkDefaultCase rhs bndr body let_bind = Let (NonRec bndr rhs) body --- | Tests whether we have to use a @case@ rather than @let@ binding for this expression --- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant" +-- | Tests whether we have to use a @case@ rather than @let@ binding for this +-- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool needsCaseBinding ty rhs = mightBeUnliftedType ty && not (exprOkForSpeculation rhs) @@ -708,7 +695,11 @@ -- in a "case" statement then they will need to manually add a dummy case branch that just -- calls "error" or similar. filterAlts _tycon inst_tys imposs_cons alts - = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + = imposs_deflt_cons `seqList` + (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which + -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter + -- leads to a huge space leak (see #22102 and !8896) where (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | Alt con _ _ <- alts_wo_default] @@ -739,9 +730,8 @@ refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts | Alt DEFAULT _ rhs : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! + , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives] + , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives] , Just all_cons <- tyConDataCons_maybe tycon , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type, so we can use @@ -801,7 +791,7 @@ which causes the KnownBranch optimisation to kick in. If we don't refine DEFAULT to `Foo ip1`, we are left with both case expressions. -2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi) +2. combineIdenticalAlts does a better job. For example (Simon Jacobi) data D = C0 | C1 | C2 case e of @@ -826,6 +816,39 @@ `imposs_deflt_cons` argument is populated with constructors which are matched elsewhere. +There are two exceptions where we avoid refining a DEFAULT case: + +* Exception 1: Newtypes + + We can have a newtype, if we are just doing an eval: + + case x of { DEFAULT -> e } + + And we don't want to fill in a default for them! + +* Exception 2: `type data` declarations + + The data constructors for a `type data` declaration (see + Note [Type data declarations] in GHC.Rename.Module) do not exist at the + value level. Nevertheless, it is possible to strictly evaluate a value + whose type is a `type data` declaration. Test case + type-data/should_compile/T2294b.hs contains an example: + + type data T a where + A :: T Int + + f :: T a -> () + f !x = () + + We want to generate the following Core for f: + + f = \(@a) (x :: T a) -> + case x of + __DEFAULT -> () + + Namely, we do _not_ want to match on `A`, as it doesn't exist at the value + level! + Note [Combine identical alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If several alternatives are identical, merge them into a single @@ -949,7 +972,7 @@ imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest elim_con1 = case con1 of -- Don't forget con1! - DEFAULT -> [] -- See Note [ + DEFAULT -> [] _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 @@ -1075,63 +1098,8 @@ go (Var v) = Just v go _ = Nothing -{- -exprIsDeadEnd is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more -expensive. --} -exprIsDeadEnd :: CoreExpr -> Bool --- See Note [Bottoming expressions] -exprIsDeadEnd e - | isEmptyTy (exprType e) - = True - | otherwise - = go 0 e - where - go n (Var v) = isDeadEndAppSig (idDmdSig v) n - go n (App e a) | isTypeArg a = go n e - | otherwise = go (n+1) e - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go n (Lam v e) | isTyVar v = go n e - go _ (Case _ _ _ alts) = null alts - -- See Note [Empty case alternatives] in GHC.Core - go _ _ = False - -{- Note [Bottoming expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsDeadEnd -checks for both of these situations: - -* Visibly-bottom computations. For example - (error Int "Hello") - is visibly bottom. The strictness analyser also finds out if - a function diverges or raises an exception, and puts that info - in its strictness signature. - -* Empty types. If a type is empty, its only inhabitant is bottom. - For example: - data T - f :: T -> Bool - f = \(x:t). case x of Bool {} - Since T has no data constructors, the case alternatives are of course - empty. However note that 'x' is not bound to a visibly-bottom value; - it's the *type* that tells us it's going to diverge. - -A GADT may also be empty even though it has constructors: - data T a where - T1 :: a -> T Bool - T2 :: T Int - ...(case (x::T Char) of {})... -Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), -which is likewise uninhabited. - - -************************************************************************ +{- ********************************************************************* * * exprIsDupable * * @@ -1225,7 +1193,6 @@ Note [exprIsCheap] ~~~~~~~~~~~~~~~~~~ - See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold @exprIsCheap@ looks at a Core expression and returns \tr{True} if @@ -1422,7 +1389,7 @@ DataConWorkId {} -> True -- Actually handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 - PrimOpId op -> primOpIsCheap op + PrimOpId op _ -> primOpIsCheap op _ -> False -- In principle we should worry about primops -- that return a type variable, since the result @@ -1454,9 +1421,8 @@ | 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 @@ -1641,7 +1607,7 @@ -- been expressed by its "wrapper", so we don't need -- to take the arguments into account - PrimOpId op + PrimOpId op _ | primOpIsDiv op , [arg1, Lit lit] <- args -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1 @@ -1661,7 +1627,7 @@ | otherwise -> primop_ok op -- Check the primop itself - && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments + && and (zipWith arg_ok arg_tys args) -- Check the arguments _ -- Unlifted types -- c.f. the Var case of exprIsHNF @@ -1673,7 +1639,8 @@ -- and we'd need to actually test n_val_args == 0. -- Partial applications - | idArity fun > n_val_args -> True + | idArity fun > n_val_args -> + and (zipWith arg_ok arg_tys args) -- Check the arguments -- Functions that terminate fast without raising exceptions etc -- See Note [Discarding unnecessary unsafeEqualityProofs] @@ -1687,9 +1654,10 @@ n_val_args = valArgCount args (arg_tys, _) = splitPiTys (idType fun) - primop_arg_ok :: TyBinder -> CoreExpr -> Bool - primop_arg_ok (Named _) _ = True -- A type argument - primop_arg_ok (Anon _ ty) arg -- A term argument + -- Used for arguments to primops and to partial applications + arg_ok :: PiTyVarBinder -> CoreExpr -> Bool + arg_ok (Named _) _ = True -- A type argument + arg_ok (Anon ty _) arg -- A term argument | Just Lifted <- typeLevity_maybe (scaledThing ty) = True -- See Note [Primops with lifted arguments] | otherwise @@ -1711,6 +1679,15 @@ -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment +-- | Should we look past this tick when eta-expanding the given function? +-- +-- See Note [Ticks and mandatory eta expansion] +-- Takes the function we are applying as argument. +etaExpansionTick :: Id -> GenTickish pass -> Bool +etaExpansionTick id t + = hasNoBinding id && + ( tickishFloatable t || isProfTick t ) + {- Note [exprOkForSpeculation: case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprOkForSpeculation accepts very special case expressions. @@ -1730,12 +1707,12 @@ ; False -> e2 } in ...) ... - Does the RHS of v satisfy the let/app invariant? Previously we said + Does the RHS of v satisfy the let-can-float invariant? Previously we said yes, on the grounds that y is evaluated. But the binder-swap done by GHC.Core.Opt.SetLevels would transform the inner alternative to DEFAULT -> ... (let v::Int# = case x of { ... } in ...) .... - which does /not/ satisfy the let/app invariant, because x is + which does /not/ satisfy the let-can-float invariant, because x is not evaluated. See Note [Binder-swap during float-out] in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler to stick to unlifted scrutinees where the issue does not @@ -1839,25 +1816,25 @@ * case x of y { DEFAULT -> ....y.... } Should 'y' (alone) be considered ok-for-speculation? - * case x of y { DEFAULT -> ....f (dataToTag# y)... } + * case x of y { DEFAULT -> ....let z = dataToTag# y... } Should (dataToTag# y) be considered ok-for-spec? You could argue 'yes', because in the case alternative we know that 'y' is evaluated. But the binder-swap transformation, which is extremely useful for float-out, changes these expressions to case x of y { DEFAULT -> ....x.... } - case x of y { DEFAULT -> ....f (dataToTag# x)... } + case x of y { DEFAULT -> ....let z = dataToTag# x... } -And now the expression does not obey the let/app invariant! Yikes! -Moreover we really might float (f (dataToTag# x)) outside the case, -and then it really, really doesn't obey the let/app invariant. +And now the expression does not obey the let-can-float invariant! Yikes! +Moreover we really might float (dataToTag# x) outside the case, +and then it really, really doesn't obey the let-can-float invariant. The solution is simple: exprOkForSpeculation does not try to take advantage of the evaluated-ness of (lifted) variables. And it returns False (always) for DataToTagOp and SeqOp. Note that exprIsHNF /can/ and does take advantage of evaluated-ness; -it doesn't have the trickiness of the let/app invariant to worry about. +it doesn't have the trickiness of the let-can-float invariant to worry about. Note [Discarding unnecessary unsafeEqualityProofs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1908,9 +1885,8 @@ -- -- > C (f x :: Int#) -- --- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't --- happen: see "GHC.Core#let_app_invariant". This invariant states that arguments of --- unboxed type must be ok-for-speculation (or trivial). +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. +-- We check for this using needsCaseBinding below exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding @@ -1924,7 +1900,7 @@ -- constructors / CONLIKE functions (as determined by the function argument) -- or PAPs. -- -exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool exprIsHNFlike is_con is_con_unf = is_hnf_like where is_hnf_like (Var v) -- NB: There are no value args at this point @@ -1965,7 +1941,13 @@ app_is_value (Tick _ f) nva = app_is_value f nva app_is_value (Cast f _) nva = app_is_value f nva app_is_value (App f a) nva - | isValArg a = app_is_value f (nva + 1) + | isValArg a = + app_is_value f (nva + 1) && + not (needsCaseBinding (exprType a) a) + -- For example f (x /# y) where f has arity two, and the first + -- argument is unboxed. This is not a value! + -- But f 34# is a value. + -- NB: Check app_is_value first, the arity check is cheaper | otherwise = app_is_value f nva app_is_value _ _ = False @@ -2045,7 +2027,7 @@ -- -- ex_tvs are intended to be used as binders for existential type args -- --- arg_ids are indended to be used as binders for value arguments, +-- arg_ids are intended to be used as binders for value arguments, -- and their types have been instantiated with inst_tys and ex_tys -- The arg_ids include both evidence and -- programmer-specified arguments (both after rep-ing) @@ -2088,7 +2070,7 @@ (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) - mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv new_tv , new_tv) @@ -2156,12 +2138,6 @@ -eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool --- Compares for equality, modulo alpha --- TODO: remove eqExpr once GHC 9.4 is released -eqExpr _ = eqCoreExpr -{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-} - -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) @@ -2187,14 +2163,17 @@ diffBinds top env binds1 = go (length binds1) env binds1 where go _ env [] [] = ([], env) - go fuel env binds1 binds2 - -- No binds left to compare? Bail out early. - | null binds1 || null binds2 - = (warn env binds1 binds2, env) + go _fuel env [] binds2 + -- No binds remaining to compare on the left? Bail out early. + = (warn env [] binds2, env) + go _fuel env binds1 [] + -- No binds remaining to compare on the right? Bail out early. + = (warn env binds1 [], env) + go fuel env binds1@(bind1:_) binds2@(_:_) -- Iterated over all binds without finding a match? Then -- try speculatively matching binders by order. | fuel == 0 - = if not $ env `inRnEnvL` fst (head binds1) + = if not $ env `inRnEnvL` fst bind1 then let env' = uncurry (rnBndrs2 env) $ unzip $ zip (sort $ map fst binds1) (sort $ map fst binds2) in go (length binds1) env' binds1 binds2 @@ -2210,7 +2189,6 @@ binds1 (binds2l ++ binds2r) | otherwise -- No match, so push back (FIXME O(n^2)) = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 - go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough -- We have tried everything, but couldn't find a good match. So -- now we just return the comparison results when we pair up @@ -2288,7 +2266,6 @@ && occInfo info1 == occInfo info2 && demandInfo info1 == demandInfo info2 && callArityInfo info1 == callArityInfo info2 - && levityInfo info1 == levityInfo info2 = locBind "in unfolding of" bndr1 bndr2 $ diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2) | otherwise @@ -2322,241 +2299,7 @@ bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 -{- -************************************************************************ -* * - Eta reduction -* * -************************************************************************ -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* We want to eta-reduce if doing so leaves a trivial expression, - *including* a cast. For example - \x. f |> co --> f |> co - (provided co doesn't mention x) - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not terminate after all. - Result: seg-fault because the boolean case actually gets a function value. - See #1947. - - So it's important to do the right thing. - -* With linear types, eta-reduction can break type-checking: - f :: A ⊸ B - g :: A -> B - g = \x. f x - - The above is correct, but eta-reducing g would yield g=f, the linter will - complain that g and f don't have the same type. - -* Note [Arity care] - ~~~~~~~~~~~~~~~~~ - We need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -Note [Eta reduction with casted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\(x:t3). f (x |> g)) :: t3 -> t2 - where - f :: t1 -> t2 - g :: t3 ~ t1 -This should be eta-reduced to - - f |> (sym g -> t2) - -So we need to accumulate a coercion, pushing it inward (past -variable arguments only) thus: - f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x - f (x:t) |> co --> (f |> (t -> co)) x - f @ a |> co --> (f |> (forall a.co)) @ a - f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) -These are the equations for ok_arg. - -It's true that we could also hope to eta reduce these: - (\xy. (f x |> g) y) - (\xy. (f x y) |> g) -But the simplifier pushes those casts outwards, so we don't -need to address that here. --} - --- When updating this function, make sure to update --- CorePrep.tryEtaReducePrep as well! -tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce rec_ids bndrs body - = go (reverse bndrs) body (mkRepReflCo (exprType body)) - where - incoming_arity = count isId bndrs - - go :: [Var] -- Binders, innermost first, types [a3,a2,a1] - -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts - -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts - -- See Note [Eta reduction with casted arguments] - -- for why we have an accumulating coercion - go [] fun co - | ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co - , not (any (`elemVarSet` used_vars) bndrs) - = Just (mkCast fun co) -- Check for any of the binders free in the result - -- including the accumulated coercion - - go bs (Tick t e) co - | tickishFloatable t - = fmap (Tick t) $ go bs e co - -- Float app ticks: \x -> Tick t (e x) ==> Tick t e - - go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) - = fmap (flip (foldr mkTick) ticks) $ go bs fun co' - -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs - ok_fun _fun = False - - --------------- - ok_fun_id fun = - -- Don't eta-reduce in fun in its own recursive RHSs - not (fun `elemUnVarSet` rec_ids) && -- criterion (R) - -- There are arguments to reduce... - fun_arity fun >= incoming_arity && - -- ... and the function can be eta reduced to arity 0 - canEtaReduceToArity fun 0 0 - --------------- - fun_arity fun -- See Note [Arity care] - | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 - -- See Note [Eta reduction of an eval'd function] - | otherwise = 0 - where - arity = idArity fun - - --------------- - ok_lam v = isTyVar v || isEvVar v - - --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) - -> Type -- Type of the function to which the argument is applied - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) - , [CoreTickish]) - -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co _ - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkHomoForAllCos [tv] co, []) - ok_arg bndr (Var v) co fun_ty - | bndr == v - , let mult = idMult bndr - , Just (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, []) - ok_arg bndr (Cast e co_arg) co fun_ty - | (ticks, Var v) <- stripTicksTop tickishFloatable e - , 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) - -- 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 - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty - = Just (co', t:ticks) - - ok_arg _ _ _ _ = Nothing - --- | Can we eta-reduce the given function to the specified arity? --- See Note [Eta reduction conditions]. -canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool -canEtaReduceToArity fun dest_join_arity dest_arity = - not $ - hasNoBinding fun - -- Don't undersaturate functions with no binding. - - || ( isJoinId fun && dest_join_arity < idJoinArity fun ) - -- Don't undersaturate join points. - -- See Note [Invariants on join points] in GHC.Core, and #20599 - - || ( dest_arity < idCbvMarkArity fun ) - -- Don't undersaturate StrictWorkerIds. - -- See Note [CBV Function Ids] in GHC.CoreToStg.Prep. - - || isLinearType (idType fun) - -- Don't perform eta reduction on linear types. - -- If `f :: A %1-> B` and `g :: A -> B`, - -- then `g x = f x` is OK but `g = f` is not. - -- See Note [Eta reduction conditions]. - -{- -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell it is not true that f = \x. f x -because f might be bottom, and 'seq' can distinguish them. - -But it *is* true that f = f `seq` \x. f x -and we'd like to simplify the latter to the former. This amounts -to the rule that - * when there is just *one* value argument, - * f is not bottom -we can eta-reduce \x. f x ===> f - -This turned up in #7542. --} - {- ********************************************************************* * * \subsection{Determining non-updatable right-hand-sides} @@ -2607,6 +2350,26 @@ , Just (tc, tc_args) <- splitTyConApp_maybe ty1 = Just (tc, tc_args, co) normSplitTyConApp_maybe _ _ = Nothing + +{- +***************************************************** +* +* InScopeSet things +* +***************************************************** +-} + + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind (InScope in_scope) binds + = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds + +extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet +extendInScopeSetBndrs (InScope in_scope) binds + = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds + +mkInScopeSetBndrs :: [CoreBind] -> InScopeSet +mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds {- ***************************************************** diff --git a/compiler/GHC/Core/Utils.hs-boot b/compiler/GHC/Core/Utils.hs-boot deleted file mode 100644 --- 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 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things. @@ -8,8 +7,9 @@ , toIfaceTvBndrs , toIfaceIdBndr , toIfaceBndr + , toIfaceTopBndr , toIfaceForAllBndr - , toIfaceTyCoVarBinders + , toIfaceForAllBndrs , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX @@ -36,6 +36,7 @@ , toIfUnfolding , toIfaceTickish , toIfaceBind + , toIfaceTopBind , toIfaceAlt , toIfaceCon , toIfaceApp @@ -62,18 +63,18 @@ 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 @@ -87,9 +88,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Utils.Trace -import Data.Maybe ( catMaybes ) +import Data.Maybe ( isNothing, catMaybes ) {- Note [Avoiding space leaks in toIface*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -149,12 +149,15 @@ | 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 + {- ************************************************************************ * * @@ -223,12 +226,6 @@ 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 @@ -236,7 +233,7 @@ where tc_name = tyConName tc info = mkIfaceTyConInfo promoted sort - promoted | isPromotedDataCon tc = IsPromoted + promoted | isDataKindsPromotedDataCon tc = IsPromoted | otherwise = NotPromoted tupleSort :: TyCon -> Maybe IfaceTyConSort @@ -296,7 +293,7 @@ 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) @@ -306,13 +303,13 @@ 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) (toIfaceCoercionX fr' co) @@ -344,7 +341,10 @@ -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! toIfaceAppArgsX fr kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args + | null ty_args + = IA_Nil + | otherwise + = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -361,15 +361,14 @@ 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) - = go (zapTCvSubst env) (substTy env ty) ts + = go (zapSubst env) (substTy env ty) ts -- See Note [Care with kind instantiation] in GHC.Core.Type | otherwise @@ -416,8 +415,8 @@ (_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) {- @@ -432,7 +431,7 @@ toIfaceBang _ HsLazy = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) -toIfaceBang _ HsStrict = IfStrict +toIfaceBang _ (HsStrict _) = IfStrict toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang @@ -445,6 +444,15 @@ -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax +toIfaceTopBndr :: Id -> IfaceTopBndrInfo +toIfaceTopBndr id + = if isExternalName name + then IfGblTopBndr name + else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id)) + where + name = getName id + toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds @@ -464,7 +472,7 @@ toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, - inline_hsinfo, unfold_hsinfo, levity_hsinfo] + inline_hsinfo, unfold_hsinfo] -- NB: strictness and arity must appear in the list before unfolding -- See GHC.IfaceToCore.tcUnfolding where @@ -498,10 +506,6 @@ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) - ------------ Representation polymorphism ---------- - levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity - | otherwise = Nothing - toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar toIfaceJoinInfo Nothing = IfaceNotJoinPoint @@ -513,20 +517,11 @@ , uf_cache = cache , uf_guidance = guidance }) = Just $ HsUnfold lb $ - case src of - InlineStable - -> case guidance of - UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -> IfInlineRule arity unsat_ok boring_ok if_rhs - _other -> IfCoreUnfold True cache if_rhs - InlineCompulsory -> IfCompulsory if_rhs - InlineRhs -> IfCoreUnfold False cache if_rhs + IfCoreUnfold src cache (toIfGuidance src guidance) (toIfaceExpr rhs) -- Yes, even if guidance is UnfNever, expose the unfolding -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would -- have stuck in NoUnfolding. For supercompilation we want -- to see that unfolding! - where - if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) @@ -543,6 +538,12 @@ toIfUnfolding _ NoUnfolding = Nothing +toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance +toIfGuidance src guidance + | UnfWhen arity unsat_ok boring_ok <- guidance + , isStableSource src = IfWhen arity unsat_ok boring_ok + | otherwise = IfNoGuidance + {- ************************************************************************ * * @@ -553,7 +554,7 @@ 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) @@ -585,10 +586,37 @@ -- should not be serialised (#8333) --------------------- -toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] +toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo +toIfaceTopBind b = + case b of + NonRec b r -> uncurry IfaceNonRec (do_one (b, r)) + Rec prs -> IfaceRec (map do_one prs) + where + do_one (b, rhs) = + let top_bndr = toIfaceTopBndr b + rhs' = case top_bndr of + -- Use the existing unfolding for a global binder if we store that anyway. + -- See Note [Interface File with Core: Sharing RHSs] + IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs) + -- Local binders will have had unfoldings trimmed so have + -- to serialise the whole RHS. + IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs) + in (top_bndr, rhs') + + -- The sharing behaviour is currently disabled due to #22807, and relies on + -- finished #220056 to be re-enabled. + disabledDueTo22807 = True + + already_has_unfolding b = not disabledDueTo22807 + && -- The identifier has an unfolding, which we are going to serialise anyway + hasCoreUnfolding (realIdUnfolding b) + -- But not a stable unfolding, we want the optimised unfoldings. + && not (isStableUnfolding (realIdUnfolding b)) + --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) @@ -628,8 +656,8 @@ 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)) @@ -637,9 +665,14 @@ | 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 + --------------------- toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo toIfaceLFInfo nm lfi = case lfi of @@ -726,7 +759,8 @@ 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 @@ -742,5 +776,35 @@ slower by 8% overall (on #9872a-d, and T1969: the reason is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop. + +Note [Interface File with Core: Sharing RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +IMPORTANT: This optimisation is currently disabled due to #22027, it can be + re-enabled once #220056 is implemented. + +In order to avoid duplicating definitions for bindings which already have unfoldings +we do some minor headstands to avoid serialising the RHS of a definition if it has +*any* unfolding. + +* Only global things have unfoldings, because local things have had their unfoldings stripped. +* For any global thing which has an unstable unfolding, we just use that. + +In order to implement this sharing: + +* When creating the interface, check the criteria above and don't serialise the RHS + if such a case. + See +* When reading an interface, look at the realIdUnfolding, and then the unfoldingTemplate. + See `tc_iface_binding` for where this happens. + +There are two main reasons why the mi_extra_decls field exists rather than shoe-horning +all the core bindings + +1. mi_extra_decls retains the recursive group structure of the original program which + is very convenient as otherwise we would have to do the analysis again when loading + the program. +2. There are additional local top-level bindings which don't make it into mi_decls. It's + best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash. -} diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -11,7 +11,7 @@ -- 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/Data/Bag.hs b/compiler/GHC/Data/Bag.hs --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} module GHC.Data.Bag ( Bag, -- abstract type @@ -18,7 +18,7 @@ concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, - concatMapBag, concatMapBagPair, mapMaybeBag, + concatMapBag, concatMapBagPair, mapMaybeBag, unzipBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, @@ -33,10 +33,10 @@ import GHC.Utils.Monad import Control.Monad import Data.Data -import Data.Maybe( mapMaybe, listToMaybe ) +import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Foldable as Foldable +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) infixr 3 `consBag` @@ -46,8 +46,8 @@ = EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty - | ListBag [a] -- INVARIANT: the list is non-empty - deriving (Functor) + | ListBag (NonEmpty a) + deriving (Foldable, Functor, Traversable) emptyBag :: Bag a emptyBag = EmptyBag @@ -91,7 +91,7 @@ isSingletonBag EmptyBag = False isSingletonBag (UnitBag _) = True isSingletonBag (TwoBags _ _) = False -- Neither is empty -isSingletonBag (ListBag xs) = isSingleton xs +isSingletonBag (ListBag (_:|xs)) = null xs filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag _ EmptyBag = EmptyBag @@ -99,7 +99,7 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 where sat1 = filterBag pred b1 sat2 = filterBag pred b2 -filterBag pred (ListBag vs) = listToBag (filter pred vs) +filterBag pred (ListBag vs) = listToBag (filter pred (toList vs)) filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) filterBagM _ EmptyBag = return EmptyBag @@ -112,7 +112,7 @@ sat2 <- filterBagM pred b2 return (sat1 `unionBags` sat2) filterBagM pred (ListBag vs) = do - sat <- filterM pred vs + sat <- filterM pred (toList vs) return (listToBag sat) allBag :: (a -> Bool) -> Bag a -> Bool @@ -136,9 +136,7 @@ anyBagM p (ListBag xs) = anyM p xs concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldr add emptyBag bss - where - add bs rs = bs `unionBags` rs +concatBag = foldr unionBags emptyBag catBagMaybes :: Bag (Maybe a) -> Bag a catBagMaybes bs = foldr add emptyBag bs @@ -156,7 +154,7 @@ where (sat1, fail1) = partitionBag pred b1 (sat2, fail2) = partitionBag pred b2 partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partition pred vs + where (sats, fails) = partition pred (toList vs) partitionBagWith :: (a -> Either b c) -> Bag a @@ -172,7 +170,7 @@ where (sat1, fail1) = partitionBagWith pred b1 (sat2, fail2) = partitionBagWith pred b2 partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partitionWith pred vs + where (sats, fails) = partitionWith pred (toList vs) foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative -> (a -> r) -- Replace UnitBag with this @@ -221,7 +219,7 @@ Nothing -> EmptyBag Just y -> UnitBag y mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) -mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) +mapMaybeBag f (ListBag xs) = listToBag $ mapMaybe f (toList xs) mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag = return EmptyBag @@ -268,7 +266,7 @@ (r2,s2) <- mapAndUnzipBagM f b2 return (TwoBags r1 r2, TwoBags s1 s2) mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs - let (rs,ss) = unzip ts + let (rs,ss) = NE.unzip ts return (ListBag rs, ListBag ss) mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function @@ -299,20 +297,31 @@ listToBag :: [a] -> Bag a listToBag [] = EmptyBag listToBag [x] = UnitBag x -listToBag vs = ListBag vs +listToBag (x:xs) = ListBag (x:|xs) nonEmptyToBag :: NonEmpty a -> Bag a nonEmptyToBag (x :| []) = UnitBag x -nonEmptyToBag (x :| xs) = ListBag (x : xs) +nonEmptyToBag xs = ListBag xs bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b +unzipBag :: Bag (a, b) -> (Bag a, Bag b) +unzipBag EmptyBag = (EmptyBag, EmptyBag) +unzipBag (UnitBag (a, b)) = (UnitBag a, UnitBag b) +unzipBag (TwoBags xs1 xs2) = (TwoBags as1 as2, TwoBags bs1 bs2) + where + (as1, bs1) = unzipBag xs1 + (as2, bs2) = unzipBag xs2 +unzipBag (ListBag xs) = (ListBag as, ListBag bs) + where + (as, bs) = NE.unzip xs + headMaybe :: Bag a -> Maybe a headMaybe EmptyBag = Nothing headMaybe (UnitBag v) = Just v headMaybe (TwoBags b1 _) = headMaybe b1 -headMaybe (ListBag l) = listToMaybe l +headMaybe (ListBag (v:|_)) = Just v instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) @@ -323,28 +332,6 @@ gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" dataCast1 x = gcast1 x - -instance Foldable.Foldable Bag where - foldr _ z EmptyBag = z - foldr k z (UnitBag x) = k x z - foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 - foldr k z (ListBag xs) = foldr k z xs - - foldl _ z EmptyBag = z - foldl k z (UnitBag x) = k z x - foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 - foldl k z (ListBag xs) = foldl k z xs - - foldl' _ z EmptyBag = z - foldl' k z (UnitBag x) = k z x - foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 - foldl' k z (ListBag xs) = foldl' k z xs - -instance Traversable Bag where - traverse _ EmptyBag = pure EmptyBag - traverse f (UnitBag x) = UnitBag <$> f x - traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 - traverse f (ListBag xs) = ListBag <$> traverse f xs instance IsList (Bag a) where type Item (Bag a) = a diff --git a/compiler/GHC/Data/Bool.hs b/compiler/GHC/Data/Bool.hs --- a/compiler/GHC/Data/Bool.hs +++ b/compiler/GHC/Data/Bool.hs @@ -4,7 +4,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic data OverridingBool = Auto diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs --- a/compiler/GHC/Data/BooleanFormula.hs +++ b/compiler/GHC/Data/BooleanFormula.hs @@ -16,15 +16,16 @@ pprBooleanFormula, pprBooleanFormulaNice ) where -import GHC.Prelude +import GHC.Prelude hiding ( init, last ) import Data.List ( nub, intersperse ) +import Data.List.NonEmpty ( NonEmpty (..), init, last ) import Data.Data import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Binary -import GHC.Parser.Annotation ( LocatedL ) +import GHC.Parser.Annotation ( LocatedL, noLocA ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set @@ -227,7 +228,7 @@ pprAnd p = cparen (p > 1) . pprAnd' pprAnd' [] = empty pprAnd' [x,y] = x <+> text "and" <+> y - pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs) pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) instance (OutputableBndr a) => Outputable (BooleanFormula a) where @@ -250,14 +251,14 @@ instance Binary a => Binary (BooleanFormula a) where put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh (unLoc <$> xs) + put_ bh (Or xs) = putByte bh 2 >> put_ bh (unLoc <$> xs) + put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x) get bh = do h <- getByte bh case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh + 0 -> Var <$> get bh + 1 -> And . fmap noLocA <$> get bh + 2 -> Or . fmap noLocA <$> get bh + _ -> Parens . noLocA <$> get bh diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs --- a/compiler/GHC/Data/EnumSet.hs +++ b/compiler/GHC/Data/EnumSet.hs @@ -15,11 +15,12 @@ import GHC.Prelude import GHC.Utils.Binary +import Control.DeepSeq import qualified Data.IntSet as IntSet newtype EnumSet a = EnumSet IntSet.IntSet - deriving (Semigroup, Monoid) + deriving (Semigroup, Monoid, NFData) member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s diff --git a/compiler/GHC/Data/FastMutInt.hs b/compiler/GHC/Data/FastMutInt.hs --- a/compiler/GHC/Data/FastMutInt.hs +++ b/compiler/GHC/Data/FastMutInt.hs @@ -13,7 +13,7 @@ atomicFetchAddFastMut ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Base diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -30,8 +30,8 @@ -- * Pointer and size of a Latin-1 encoded string. -- * Practically no operations. -- * Outputting them is fast. --- * Generated by 'mkPtrString'. --- * Length of string literals (mkPtrString "abc") is computed statically +-- * Generated by 'mkPtrString#'. +-- * Length of string literals (mkPtrString# "abc"#) is computed statically -- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext' -- * Requires manual memory management. -- Improper use may lead to memory leaks or dangling pointers. @@ -56,6 +56,7 @@ FastZString, hPutFZS, zString, + zStringTakeN, lengthFZS, -- * FastStrings @@ -82,11 +83,9 @@ lengthFS, nullFS, appendFS, - headFS, concatFS, consFS, nilFS, - isUnderscoreFS, lexicalCompareFS, uniqCompareFS, @@ -102,16 +101,16 @@ -- ** Construction mkPtrString#, - mkPtrString, -- ** Deconstruction unpackPtrString, + unpackPtrStringTakeN, -- ** Operations lengthPS ) where -import GHC.Prelude as Prelude +import GHC.Prelude.Basic as Prelude import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe @@ -135,7 +134,6 @@ import System.IO import Data.Data import Data.IORef -import Data.Char import Data.Semigroup as Semi import Foreign @@ -183,6 +181,14 @@ zString (FastZString bs) = inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen +-- | @zStringTakeN n = 'take' n . 'zString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'FastZString'. +zStringTakeN :: Int -> FastZString -> String +zStringTakeN n (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(cp, len) -> + peekCAStringLen (cp, min n len) + lengthFZS :: FastZString -> Int lengthFZS (FastZString bs) = BS.length bs @@ -459,8 +465,7 @@ FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket sbs - case res of + case bucket_match bucket sbs of Just found -> return found Nothing -> do -- The withMVar below is not dupable. It can lead to deadlock if it is @@ -479,8 +484,7 @@ FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket sbs - case res of + case bucket_match bucket sbs of -- The FastString was added by another thread after previous read and -- before we acquired the write lock. Just found -> return found @@ -491,11 +495,12 @@ _ <- atomicFetchAddFastMut counter 1 return fs -bucket_match :: [FastString] -> ShortByteString -> IO (Maybe FastString) -bucket_match [] _ = return Nothing -bucket_match (fs@(FastString {fs_sbs=fs_sbs}) : ls) sbs - | fs_sbs == sbs = return (Just fs) - | otherwise = bucket_match ls sbs +bucket_match :: [FastString] -> ShortByteString -> Maybe FastString +bucket_match fs sbs = go fs + where go [] = Nothing + go (fs@(FastString {fs_sbs=fs_sbs}) : ls) + | fs_sbs == sbs = Just fs + | otherwise = go ls mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = @@ -531,13 +536,13 @@ {-# NOINLINE[1] mkFastString #-} mkFastString str = inlinePerformIO $ do - sbs <- utf8EncodeShortByteString str + let !sbs = utf8EncodeShortByteString str mkFastStringWith (mkNewFastStringShortByteString sbs) sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. {-# RULES -"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeString x #-} +"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-} -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString @@ -554,7 +559,7 @@ -> FastMutInt -> IO FastString mkNewFastStringShortByteString sbs uid n_zencs = do let zstr = mkZFastString n_zencs sbs - chars <- countUTF8Chars sbs + chars = utf8CountCharsShortByteString sbs return (FastString uid chars sbs zstr) hashStr :: ShortByteString -> Int @@ -590,7 +595,7 @@ nullFS :: FastString -> Bool nullFS fs = SBS.null $ fs_sbs fs --- | Unpacks and decodes the FastString +-- | Lazily unpacks and decodes the FastString unpackFS :: FastString -> String unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs @@ -609,11 +614,6 @@ concatFS :: [FastString] -> FastString concatFS = mkFastStringShortByteString . mconcat . map fs_sbs -headFS :: FastString -> Char -headFS fs - | SBS.null $ fs_sbs fs = panic "headFS: Empty FastString" -headFS fs = head $ unpackFS fs - consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) @@ -629,9 +629,6 @@ nilFS :: FastString nilFS = mkFastString "" -isUnderscoreFS :: FastString -> Bool -isUnderscoreFS fs = fs == fsLit "_" - -- ----------------------------------------------------------------------------- -- Stats @@ -673,34 +670,18 @@ {-# INLINE mkPtrString# #-} mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) --- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 --- encoding. The original string must not contain non-Latin-1 characters --- (above codepoint @0xff@). -{-# NOINLINE[0] mkPtrString #-} -- see rules below -mkPtrString :: String -> PtrString -mkPtrString s = - -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks - -- and because someone might be using `eqAddr#` to check for string equality. - unsafePerformIO (do - let len = length s - p <- mallocBytes len - let - loop :: Int -> String -> IO () - loop !_ [] = return () - loop n (c:cs) = do - pokeByteOff p n (fromIntegral (ord c) :: Word8) - loop (1+n) cs - loop 0 s - return (PtrString p len) - ) - -{-# RULES "mkPtrString" - forall x . mkPtrString (unpackCString# x) = mkPtrString# x #-} - -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'PtrString'. +unpackPtrStringTakeN :: Int -> PtrString -> String +unpackPtrStringTakeN n (PtrString (Ptr p#) len) = + case min n len of + I# n# -> unpackNBytes# p# n# -- | Return the length of a 'PtrString' lengthPS :: PtrString -> Int diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs --- a/compiler/GHC/Data/Graph/Directed.hs +++ b/compiler/GHC/Data/Graph/Directed.hs @@ -7,12 +7,13 @@ module GHC.Data.Graph.Directed ( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + graphFromVerticesAndAdjacency, - SCC(..), Node(..), flattenSCC, flattenSCCs, + SCC(..), Node(..), G.flattenSCC, G.flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, allReachable, outgoingG, + reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG, emptyG, findCycle, @@ -57,7 +58,7 @@ import qualified Data.Set as Set import qualified Data.Graph as G -import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation import Data.Tree import GHC.Types.Unique import GHC.Types.Unique.FM @@ -290,19 +291,11 @@ -} stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG graph = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) - -decodeSccs :: Graph node -> Forest Vertex -> [SCC node] -decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest - = map decode forest - where - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) +stronglyConnCompG graph = decodeSccs graph $ scc (gr_int_graph graph) +decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node] +decodeSccs Graph { gr_vertex_to_node = vertex_fn } + = map (fmap vertex_fn) -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] @@ -333,7 +326,7 @@ => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesOrdR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd + stronglyConnCompG . graphFromEdgedVerticesOrd -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info @@ -344,7 +337,7 @@ => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesUniqR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq + stronglyConnCompG . graphFromEdgedVerticesUniq {- ************************************************************************ @@ -356,7 +349,7 @@ topologicalSortG :: Graph node -> [node] topologicalSortG graph = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph) reachableG :: Graph node -> node -> [node] reachableG graph from = map (gr_vertex_to_node graph) result @@ -376,22 +369,31 @@ vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] -- | Efficiently construct a map which maps each key to it's set of transitive --- dependencies. +-- dependencies. Only works on acyclic input. allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key) -allReachable (Graph g from _) conv = - M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) `S.insert` vs) S.empty vs) - | (v, vs) <- IM.toList int_graph] +allReachable = all_reachable reachableGraph + +-- | Efficiently construct a map which maps each key to it's set of transitive +-- dependencies. Less efficient than @allReachable@, but works on cyclic input as well. +allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key) +allReachableCyclic = all_reachable reachableGraphCyclic + +all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key) +all_reachable int_reachables (Graph g from _) keyOf = + M.fromList [(k, IS.foldr (\v' vs -> keyOf (from v') `S.insert` vs) S.empty vs) + | (v, vs) <- IM.toList int_graph + , let k = keyOf (from v)] where - int_graph = reachableGraph g + int_graph = int_reachables g hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node verticesG :: Graph node -> [node] -verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) +verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph) edgesG :: Graph node -> [Edge node] -edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph) where v2n = gr_vertex_to_node graph transposeG :: Graph node -> Graph node @@ -451,14 +453,64 @@ -- This generalizes reachable which was found in Data.Graph reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (dfs g vs) +reachable g vs = preorderF (G.dfs g vs) reachableGraph :: IntGraph -> IM.IntMap IS.IntSet reachableGraph g = res where do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v)) - res = IM.fromList [(v, do_one v) | v <- vertices g] + res = IM.fromList [(v, do_one v) | v <- G.vertices g] +scc :: IntGraph -> [SCC Vertex] +scc graph = map decode forest + where + forest = {-# SCC "Digraph.scc" #-} G.scc graph + + decode (Node v []) | mentions_itself v = CyclicSCC [v] + | otherwise = AcyclicSCC v + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + +reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet +reachableGraphCyclic g = foldl' add_one_comp mempty comps + where + neighboursOf v = g!v + + comps = scc g + + -- To avoid divergence on cyclic input, we build the result + -- strongly connected component by component, in topological + -- order. For each SCC, we know that: + -- + -- * All vertices in the component can reach all other vertices + -- in the component ("local" reachables) + -- + -- * Other reachable vertices ("remote" reachables) must come + -- from earlier components, either via direct neighbourhood, or + -- transitively from earlier reachability map + -- + -- This allows us to build the extension of the reachability map + -- directly, without any self-reference, thereby avoiding a loop. + add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet + add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier + where + earlier_neighbours = neighboursOf v + earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours + all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further) + add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier + where + all_locals = IS.fromList vs + local v = IS.delete v all_locals + -- Arguably, for a cyclic SCC we should include each + -- vertex in its own reachable set. However, this could + -- lead to a lot of extra pain in client code to avoid + -- looping when traversing the reachability map. + all_neighbours = IS.fromList (concatMap neighboursOf vs) + earlier_neighbours = all_neighbours IS.\\ all_locals + earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours) + all_remotes = IS.unions (earlier_neighbours : earlier_further) + {- ************************************************************************ * * @@ -547,3 +599,21 @@ ends'' = addToUFM ends' n time'' in (time'' + 1, starts'', ends'') + +graphFromVerticesAndAdjacency + :: Ord key + => [Node key payload] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (Node key payload) +graphFromVerticesAndAdjacency [] _ = emptyGraph +graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) + reduced_edges = map key_vertex_pair edges + graph = G.buildG bounds reduced_edges diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs --- a/compiler/GHC/Data/Graph/UnVar.hs +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -16,7 +16,7 @@ -} 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 @@ , 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 @@ -43,13 +43,16 @@ -- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. -- Therefore, use a IntSet directly (which is likely also a bit more efficient). --- Set of uniques, i.e. for adjancet nodes +-- Set of uniques, i.e. for adjacent nodes newtype UnVarSet = UnVarSet (S.IntSet) deriving Eq 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 @@ -74,9 +77,6 @@ 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/Data/List/Infinite.hs b/compiler/GHC/Data/List/Infinite.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/List/Infinite.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} + +module GHC.Data.List.Infinite + ( Infinite (..) + , head, tail + , filter + , (++) + , unfoldr + , (!!) + , groupBy + , dropList + , iterate + , concatMap + , allListsOf + , toList + , repeat + ) where + +import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise) +import Control.Category (Category (..)) +import Control.Monad (guard) +import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty (..)) +import qualified GHC.Base as List (build) + +data Infinite a = Inf a (Infinite a) + deriving (Foldable, Functor, Traversable) + +head :: Infinite a -> a +head (Inf a _) = a +{-# NOINLINE [1] head #-} + +tail :: Infinite a -> Infinite a +tail (Inf _ as) = as +{-# NOINLINE [1] tail #-} + +{-# RULES +"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x + #-} + +instance Applicative Infinite where + pure = repeat + Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) + +mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b +mapMaybe f = go + where + go (Inf a as) = let bs = go as in case f a of + Nothing -> bs + Just b -> Inf b bs +{-# NOINLINE [1] mapMaybe #-} + +{-# RULES +"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as +"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f + #-} + +{-# INLINE [0] mapMaybeFB #-} +mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r +mapMaybeFB cons f a bs = case f a of + Nothing -> bs + Just r -> cons r bs + +filter :: (a -> Bool) -> Infinite a -> Infinite a +filter f = mapMaybe (\ a -> a <$ guard (f a)) +{-# INLINE filter #-} + +infixr 5 ++ +(++) :: Foldable f => f a -> Infinite a -> Infinite a +(++) = flip (F.foldr Inf) + +unfoldr :: (b -> (a, b)) -> b -> Infinite a +unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b +{-# INLINE unfoldr #-} + +(!!) :: Infinite a -> Int -> a +Inf a _ !! 0 = a +Inf _ as !! n = as !! (n-1) + +groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a) +groupBy eq = go + where + go (Inf a as) = Inf (a:|bs) (go cs) + where (bs, cs) = span (eq a) as + +span :: (a -> Bool) -> Infinite a -> ([a], Infinite a) +span p = spanJust (\ a -> a <$ guard (p a)) +{-# INLINE span #-} + +spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a) +spanJust p = go + where + go as@(Inf a as') + | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs) + | otherwise = ([], as) + +iterate :: (a -> a) -> a -> Infinite a +iterate f = go where go a = Inf a (go (f a)) +{-# NOINLINE [1] iterate #-} + +{-# RULES +"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a) +"iterateFB" [1] iterateFB Inf = iterate + #-} + +iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b +iterateFB c f a = go a + where go a = a `c` go (f a) +{-# INLINE [0] iterateFB #-} + +concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b +concatMap f = go where go (Inf a as) = f a ++ go as +{-# NOINLINE [1] concatMap #-} + +{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-} + +{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-} + +foldr :: (a -> b -> b) -> Infinite a -> b +foldr f = go where go (Inf a as) = f a (go as) +{-# INLINE [0] foldr #-} + +build :: (forall b . (a -> b -> b) -> b) -> Infinite a +build g = g Inf +{-# INLINE [1] build #-} + +-- Analogous to 'foldr'/'build' fusion for '[]' +{-# RULES +"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f +"foldr/id" foldr Inf = id + +"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f) + #-} + +{-# RULES +"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as +"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g) +"mapFB/id" forall c . mapFB c (\ x -> x) = c + #-} + +mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c +mapFB c f = \ x ys -> c (f x) ys +{-# INLINE [0] mapFB #-} + +dropList :: [a] -> Infinite b -> Infinite b +dropList [] bs = bs +dropList (_:as) (Inf _ bs) = dropList as bs + +-- | Compute all lists of the given alphabet. +-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@ +allListsOf :: [a] -> Infinite [a] +allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as) + +-- See Note [Fusion for `Infinite` lists]. +toList :: Infinite a -> [a] +toList = \ as -> List.build (\ c _ -> foldr c as) +{-# INLINE toList #-} + +repeat :: a -> Infinite a +repeat a = as where as = Inf a as +{-# INLINE [0] repeat #-} + +repeatFB :: (a -> b -> b) -> a -> b +repeatFB c x = xs where xs = c x xs +{-# INLINE [0] repeatFB #-} + +{-# RULES +"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a +"repeatFB" [1] repeatFB Inf = repeat + #-} + +{- +Note [Fusion for `Infinite` lists] +~~~~~~~~~~~~~~~~~~~~ +We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in +GHC.Base to support fusion for regular lists. In particular, we define the following: +• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a` +• `foldr :: (a -> b -> b) -> Infinite a -> b` +• A RULE `foldr f (build g) = g f` +• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in + terms of `foldr` + +This can work across data types. For example, consider `toList :: Infinite a -> [a]`. +We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]'). +Ergo, we define it in terms of 'Infinite.foldr' and `List.build`. + +For a bigger example, consider `List.map f (toList (Infinite.map g as))` + +We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`, +and the list structure between `toList` and `List.map`. And indeed we do: see test +"InfiniteListFusion". +-} diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs --- a/compiler/GHC/Data/List/SetOps.hs +++ b/compiler/GHC/Data/List/SetOps.hs @@ -12,7 +12,7 @@ -- -- Avoid using them as much as possible module GHC.Data.List.SetOps ( - unionLists, minusList, + unionLists, unionListsOrd, minusList, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, @@ -33,7 +33,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Utils.Trace import qualified Data.List as L import qualified Data.List.NonEmpty as NE @@ -54,6 +53,19 @@ -} + +-- | Combines the two lists while keeping their order, placing the first argument +-- first in the result. +-- +-- Uses a set internally to record duplicates. This makes it slightly slower for +-- very small lists but avoids quadratic behaviour for large lists. +unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a] +unionListsOrd xs ys + -- Since both arguments don't have internal duplicates we can just take all of xs + -- and every element of ys that's not already in xs. + = let set_ys = S.fromList ys + in (filter (\e -> not $ S.member e set_ys) xs) ++ ys + -- | Assumes that the arguments contain no duplicates unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] -- We special case some reasonable common patterns. @@ -161,7 +173,7 @@ eq a b = case cmp a b of { EQ -> True; _ -> False } -- | Remove the duplicates from a list using the provided --- comparison function. +-- comparison function. Might change the order of elements. -- -- Returns the list without duplicates, and accumulates -- all the duplicates in the second component of its result. diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs --- a/compiler/GHC/Data/Maybe.hs +++ b/compiler/GHC/Data/Maybe.hs @@ -32,7 +32,7 @@ import Control.Monad.Trans.Maybe import Control.Exception (SomeException(..)) import Data.Maybe -import Data.Foldable ( foldlM ) +import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty ) @@ -71,8 +71,7 @@ expectJust err Nothing = error ("expectJust " ++ err) whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () +whenIsJust = for_ -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a diff --git a/compiler/GHC/Data/OrdList.hs b/compiler/GHC/Data/OrdList.hs --- a/compiler/GHC/Data/OrdList.hs +++ b/compiler/GHC/Data/OrdList.hs @@ -8,7 +8,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} -- | Provide trees (of instructions), so that lists of instructions can be @@ -28,6 +27,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semigroup infixl 5 `appOL` @@ -37,7 +38,7 @@ data OrdList a = None | One a - | Many [a] -- Invariant: non-empty + | Many (NonEmpty a) | Cons a (OrdList a) | Snoc (OrdList a) a | Two (OrdList a) -- Invariant: non-empty @@ -100,8 +101,12 @@ pattern ConsOL x xs <- (viewCons -> VJust x xs) where ConsOL x xs = consOL x xs {-# COMPLETE NilOL, ConsOL #-} + viewCons :: OrdList a -> VMaybe a (OrdList a) -viewCons (One a) = VJust a NilOL +viewCons None = VNothing +viewCons (One a) = VJust a NilOL +viewCons (Many (a :| [])) = VJust a NilOL +viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs)) viewCons (Cons a as) = VJust a as viewCons (Snoc as a) = case viewCons as of VJust a' as' -> VJust a' (Snoc as' a) @@ -109,15 +114,18 @@ viewCons (Two as1 as2) = case viewCons as1 of VJust a' as1' -> VJust a' (Two as1' as2) VNothing -> viewCons as2 -viewCons _ = VNothing pattern SnocOL :: OrdList a -> a -> OrdList a pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where SnocOL xs x = snocOL xs x {-# COMPLETE NilOL, SnocOL #-} + viewSnoc :: OrdList a -> VMaybe (OrdList a) a -viewSnoc (One a) = VJust NilOL a -viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a +viewSnoc None = VNothing +viewSnoc (One a) = VJust NilOL a +viewSnoc (Many as) = (`VJust` NE.last as) $ case NE.init as of + [] -> NilOL + b : bs -> Many (b :| bs) viewSnoc (Snoc as a) = VJust as a viewSnoc (Cons a as) = case viewSnoc as of VJust as' a' -> VJust (Cons a as') a' @@ -125,18 +133,17 @@ viewSnoc (Two as1 as2) = case viewSnoc as2 of VJust as2' a' -> VJust (Two as1 as2') a' VNothing -> viewSnoc as1 -viewSnoc _ = VNothing headOL None = panic "headOL" headOL (One a) = a -headOL (Many as) = head as +headOL (Many as) = NE.head as headOL (Cons a _) = a headOL (Snoc as _) = headOL as headOL (Two as _) = headOL as lastOL None = panic "lastOL" lastOL (One a) = a -lastOL (Many as) = last as +lastOL (Many as) = NE.last as lastOL (Cons _ as) = lastOL as lastOL (Snoc _ a) = a lastOL (Two _ as) = lastOL as @@ -164,7 +171,7 @@ go (Cons a b) acc = a : go b acc go (Snoc a b) acc = go a (b:acc) go (Two a b) acc = go a (go b acc) - go (Many xs) acc = xs ++ acc + go (Many xs) acc = NE.toList xs ++ acc fromOLReverse :: OrdList a -> [a] fromOLReverse a = go a [] @@ -175,7 +182,7 @@ go (Cons a b) acc = go b (a : acc) go (Snoc a b) acc = b : go a acc go (Two a b) acc = go b (go a acc) - go (Many xs) acc = reverse xs ++ acc + go (Many xs) acc = reverse (NE.toList xs) ++ acc mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap @@ -192,7 +199,9 @@ mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1 !b2' = mapOL' f b2 in Two b1' b2' -mapOL' f (Many xs) = Many $! strictMap f xs +mapOL' f (Many (x :| xs)) = let !x1 = f x + !xs1 = strictMap f xs + in Many (x1 :| xs1) foldrOL :: (a->b->b) -> b -> OrdList a -> b foldrOL _ z None = z @@ -214,7 +223,7 @@ toOL :: [a] -> OrdList a toOL [] = None toOL [x] = One x -toOL xs = Many xs +toOL (x : xs) = Many (x :| xs) reverseOL :: OrdList a -> OrdList a reverseOL None = None @@ -222,7 +231,7 @@ reverseOL (Cons a b) = Snoc (reverseOL b) a reverseOL (Snoc a b) = Cons b (reverseOL a) reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) -reverseOL (Many xs) = Many (reverse xs) +reverseOL (Many xs) = Many (NE.reverse xs) -- | Compare not only the values but also the structure of two lists strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool diff --git a/compiler/GHC/Data/Pair.hs b/compiler/GHC/Data/Pair.hs --- a/compiler/GHC/Data/Pair.hs +++ b/compiler/GHC/Data/Pair.hs @@ -4,7 +4,7 @@ -} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Data.Pair ( Pair(..) @@ -22,7 +22,7 @@ import qualified Data.Semigroup as Semi data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Functor) + deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -33,12 +33,6 @@ instance Applicative Pair where pure x = Pair x x (Pair f g) <*> (Pair x y) = Pair (f x) (g y) - -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y instance Semi.Semigroup a => Semi.Semigroup (Pair a) where Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) diff --git a/compiler/GHC/Data/Stream.hs b/compiler/GHC/Data/Stream.hs --- a/compiler/GHC/Data/Stream.hs +++ b/compiler/GHC/Data/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} -- ----------------------------------------------------------------------------- @@ -66,9 +67,7 @@ data StreamS m a b = Yield a (StreamS m a b) | Done b | Effect (m (StreamS m a b)) - -instance Monad m => Functor (StreamS m a) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (StreamS m a) where pure = Done @@ -126,7 +125,7 @@ -- | Note this is not very efficient because it traverses the whole stream -- before rebuilding it, avoid using it if you can. mapAccumL used to -- implemented but it wasn't used anywhere in the compiler and has similar --- effiency problems. +-- efficiency problems. mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r -> Stream m b (c, r) mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str) diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -199,7 +199,7 @@ let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) unsafeWithForeignPtr buf $ \ptr -> do - utf8EncodeStringPtr ptr str + utf8EncodePtr ptr str pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) @@ -297,7 +297,7 @@ inlinePerformIO $ unsafeWithForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) - return (fst (utf8DecodeChar p')) + return (fst (utf8DecodeCharPtr p')) -- ----------------------------------------------------------------------------- -- Moving @@ -383,7 +383,7 @@ -> String lexemeToString _ 0 = "" lexemeToString (StringBuffer buf _ cur) bytes = - utf8DecodeStringLazy buf cur bytes + utf8DecodeForeignPtr buf cur bytes lexemeToFastString :: StringBuffer -> Int -- ^ @n@, the number of bytes @@ -405,7 +405,7 @@ go buf0 n acc p | n == 0 || buf0 >= p = return acc go buf0 n acc p = do p' <- utf8PrevChar p - let (c,_) = utf8DecodeChar p' + let (c,_) = utf8DecodeCharPtr p' go buf0 (n - 1) (c:acc) p' -- ----------------------------------------------------------------------------- @@ -414,7 +414,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let go i x | i == len = x - | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of + | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of '_' -> go (i + 1) x -- skip "_" (#14473) char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs --- a/compiler/GHC/Data/TrieMap.hs +++ b/compiler/GHC/Data/TrieMap.hs @@ -66,12 +66,11 @@ type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) -- or an existing elt (Just) -class TrieMap m where +class Functor m => TrieMap m where type Key m :: Type emptyTM :: m a lookupTM :: forall b. Key m -> m b -> Maybe b alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b filterTM :: (a -> Bool) -> m a -> m a foldTM :: (a -> b -> b) -> m a -> b -> b @@ -117,6 +116,25 @@ deMaybe (Just m) = m {- +Note [Every TrieMap is a Functor] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every TrieMap T admits + fmap :: (a->b) -> T a -> T b +where (fmap f t) applies `f` to every element of the range of `t`. +Ergo, we make `Functor` a superclass of `TrieMap`. + +Moreover it is almost invariably possible to /derive/ Functor for each +particular instance. E.g. in the list instance we have + data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + deriving (Functor) + instance TrieMap m => TrieMap (ListMap m) where { .. } + +Alas, we not yet derive `Functor` for reasons of performance; see #22292. +-} + +{- ************************************************************************ * * IntMaps @@ -130,7 +148,6 @@ lookupTM k m = IntMap.lookup k m alterTM = xtInt foldTM k m z = IntMap.foldr k z m - mapTM f m = IntMap.map f m filterTM f m = IntMap.filter f m xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a @@ -142,7 +159,6 @@ lookupTM = Map.lookup alterTM k f m = Map.alter f k m foldTM k m z = Map.foldr k z m - mapTM f m = Map.map f m filterTM f m = Map.filter f m @@ -219,7 +235,6 @@ lookupTM k m = lookupUDFM m k alterTM k f m = alterUDFM f m k foldTM k m z = foldUDFM k z m - mapTM f m = mapUDFM f m filterTM f m = filterUDFM f m {- @@ -235,22 +250,22 @@ data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } +-- TODO(22292): derive +instance Functor m => Functor (MaybeMap m) where + fmap f MM { mm_nothing = mn, mm_just = mj } = MM + { mm_nothing = fmap f mn, mm_just = fmap f mj } + instance TrieMap m => TrieMap (MaybeMap m) where type Key (MaybeMap m) = Maybe (Key m) emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } lookupTM = lkMaybe lookupTM alterTM = xtMaybe alterTM foldTM = fdMaybe - mapTM = mapMb filterTM = ftMaybe instance TrieMap m => Foldable (MaybeMap m) where foldMap = foldMapTM -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - lkMaybe :: (forall b. k -> m b -> Maybe b) -> Maybe k -> MaybeMap m a -> Maybe a lkMaybe _ Nothing = mm_nothing @@ -290,13 +305,17 @@ = LM { lm_nil :: Maybe a , lm_cons :: m (ListMap m a) } +-- TODO(22292): derive +instance Functor m => Functor (ListMap m) where + fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM + { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons } + instance TrieMap m => TrieMap (ListMap m) where type Key (ListMap m) = [Key m] emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } lookupTM = lkList lookupTM alterTM = xtList alterTM foldTM = fdList - mapTM = mapList filterTM = ftList instance TrieMap m => Foldable (ListMap m) where @@ -305,10 +324,6 @@ instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where ppr m = text "List elts" <+> ppr (foldTM (:) m []) -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) -> [k] -> ListMap m a -> Maybe a lkList _ [] = lm_nil @@ -326,7 +341,7 @@ ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a ftList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons } + = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } {- ************************************************************************ @@ -380,6 +395,11 @@ ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v ppr (MultiMap m) = ppr m +-- TODO(22292): derive +instance Functor m => Functor (GenMap m) where + fmap = mapG + {-# INLINE fmap #-} + -- TODO undecidable instance instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where type Key (GenMap m) = Key m @@ -387,7 +407,6 @@ lookupTM = lkG alterTM = xtG foldTM = fdG - mapTM = mapG filterTM = ftG instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where @@ -431,10 +450,10 @@ xtG k f (MultiMap m) = MultiMap (alterTM k f m) {-# INLINEABLE mapG #-} -mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b +mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b mapG _ EmptyMap = EmptyMap mapG f (SingletonMap k v) = SingletonMap k (f v) -mapG f (MultiMap m) = MultiMap (mapTM f m) +mapG f (MultiMap m) = MultiMap (fmap f m) {-# INLINEABLE fdG #-} fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b diff --git a/compiler/GHC/Data/Unboxed.hs b/compiler/GHC/Data/Unboxed.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/Unboxed.hs @@ -0,0 +1,49 @@ +-- Unboxed counterparts to data structures + +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module GHC.Data.Unboxed ( + MaybeUB(JustUB, NothingUB), + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + ) where + +import GHC.Prelude hiding (Maybe(..), Either(..)) + +-- | Like Maybe, but using unboxed sums. +-- +-- Use with care. Using a unboxed maybe is not always a win +-- in execution *time* even when allocations go down. So make +-- sure to benchmark for execution time as well. If the difference +-- in *runtime* for the compiler is too small to measure it's likely +-- better to use a regular Maybe instead. +-- +-- This is since it causes more function arguments to be passed, and +-- potentially more variables to be captured by closures increasing +-- closure size. +newtype MaybeUB a = MaybeUB (# (# #) | a #) + +pattern JustUB :: a -> MaybeUB a +pattern JustUB x = MaybeUB (# | x #) + +pattern NothingUB :: MaybeUB a +pattern NothingUB = MaybeUB (# (# #) | #) + +{-# COMPLETE NothingUB, JustUB #-} + +fromMaybeUB :: a -> MaybeUB a -> a +fromMaybeUB d NothingUB = d +fromMaybeUB _ (JustUB x) = x + +apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b +apMaybeUB (JustUB f) (JustUB x) = JustUB (f x) +apMaybeUB _ _ = NothingUB + +fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b +fmapMaybeUB _f NothingUB = NothingUB +fmapMaybeUB f (JustUB x) = JustUB $ f x + +maybeUB :: b -> (a -> b) -> MaybeUB a -> b +maybeUB _def f (JustUB x) = f x +maybeUB def _f NothingUB = def diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -1,131 +1,990 @@ {-# LANGUAGE MultiWayIf #-} --- | Code generation backends -module GHC.Driver.Backend - ( Backend (..) - , platformDefaultBackend - , platformNcgSupported - , backendProducesObject - , backendRetainsAllBindings - ) -where - -import GHC.Prelude -import GHC.Platform - --- | Code generation backends. --- --- GHC supports several code generation backends serving different purposes --- (producing machine code, producing ByteCode for the interpreter) and --- supporting different platforms. --- -data Backend - = NCG -- ^ Native code generator backend. - -- - -- Compiles Cmm code into textual assembler, then relies on - -- an external assembler toolchain to produce machine code. - -- - -- Only supports a few platforms (X86, PowerPC, SPARC). - -- - -- See "GHC.CmmToAsm". - - - | LLVM -- ^ LLVM backend. - -- - -- Compiles Cmm code into LLVM textual IR, then relies on - -- LLVM toolchain to produce machine code. - -- - -- It relies on LLVM support for the calling convention used - -- by the NCG backend to produce code objects ABI compatible - -- with it (see "cc 10" or "ghccc" calling convention in - -- https://llvm.org/docs/LangRef.html#calling-conventions). - -- - -- Support a few platforms (X86, AArch64, s390x, ARM). - -- - -- See "GHC.CmmToLlvm" - - - | ViaC -- ^ Via-C backend. - -- - -- Compiles Cmm code into C code, then relies on a C compiler - -- to produce machine code. - -- - -- It produces code objects that are *not* ABI compatible - -- with those produced by NCG and LLVM backends. - -- - -- Produced code is expected to be less efficient than the - -- one produced by NCG and LLVM backends because STG - -- registers are not pinned into real registers. On the - -- other hand, it supports more target platforms (those - -- having a valid C toolchain). - -- - -- See "GHC.CmmToC" - - - | Interpreter -- ^ ByteCode interpreter. - -- - -- Produce ByteCode objects (BCO, see "GHC.ByteCode") that - -- can be interpreted. It is used by GHCi. - -- - -- Currently some extensions are not supported - -- (foreign primops). - -- - -- See "GHC.StgToByteCode" - - - | NoBackend -- ^ No code generated. - -- - -- Use this to disable code generation. It is particularly - -- useful when GHC is used as a library for other purpose - -- than generating code (e.g. to generate documentation with - -- Haddock) or when the user requested it (via -fno-code) for - -- some reason. - - deriving (Eq,Ord,Show,Read) - --- | Default backend to use for the given platform. -platformDefaultBackend :: Platform -> Backend -platformDefaultBackend platform = if - | platformUnregisterised platform -> ViaC - | platformNcgSupported platform -> NCG - | otherwise -> LLVM - - --- | Is the platform supported by the Native Code Generator? -platformNcgSupported :: Platform -> Bool -platformNcgSupported platform = if - | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI - | ncgValidArch -> True - | otherwise -> False - where - ncgValidArch = case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - ArchPPC -> True - ArchPPC_64 {} -> True - ArchAArch64 -> True - _ -> False - --- | Will this backend produce an object file on the disk? -backendProducesObject :: Backend -> Bool -backendProducesObject ViaC = True -backendProducesObject NCG = True -backendProducesObject LLVM = True -backendProducesObject Interpreter = False -backendProducesObject NoBackend = False - --- | Does this backend retain *all* top-level bindings for a module, --- rather than just the exported bindings, in the TypeEnv and compiled --- code (if any)? --- --- Interpreter backend does this, so that GHCi can call functions inside a --- module. --- --- When no backend is used we also do it, so that Haddock can get access to the --- GlobalRdrEnv for a module after typechecking it. -backendRetainsAllBindings :: Backend -> Bool -backendRetainsAllBindings Interpreter = True -backendRetainsAllBindings NoBackend = True -backendRetainsAllBindings ViaC = False -backendRetainsAllBindings NCG = False -backendRetainsAllBindings LLVM = False +{-| +Module : GHC.Driver.Backend +Description : Back ends for code generation + +This module exports the `Backend` type and all the available values +of that type. The type is abstract, and GHC assumes a "closed world": +all the back ends are known and are known here. The compiler driver +chooses a `Backend` value based on how it is asked to generate code. + +A `Backend` value encapsulates the knowledge needed to take Cmm, STG, +or Core and write assembly language to a file. A back end also +provides a function that enables the compiler driver to run an +assembler on the code that is written, if any (the "post-backend +pipeline"). Finally, a back end has myriad /properties/. Properties +mediate interactions between a back end and the rest of the compiler, +especially the driver. Examples include the following: + + * Property `backendValidityOfCImport` says whether the back end can + import foreign C functions. + + * Property `backendForcesOptimization0` says whether the back end can + be used with optimization levels higher than `-O0`. + + * Property `backendCDefs` tells the compiler driver, "if you're using + this back end, then these are the command-line flags you should add + to any invocation of the C compiler." + +These properties are used elsewhere in GHC, primarily in the driver, to +fine-tune operations according to the capabilities of the chosen back +end. You might use a property to make GHC aware of a potential +limitation of certain back ends, or a special feature available only +in certain back ends. If your client code needs to know a fact that +is not exposed in an existing property, you would define and export a +new property. Conditioning client code on the /identity/ or /name/ of +a back end is Not Done. + +For full details, see the documentation of each property. +-} + +module GHC.Driver.Backend + ( -- * The @Backend@ type + Backend -- note: type is abstract + -- * Available back ends + , ncgBackend + , llvmBackend + , jsBackend + , viaCBackend + , interpreterBackend + , noBackend + , allBackends + + -- * Types used to specify properties of back ends + , PrimitiveImplementation(..) + -- ** Properties that stand for functions + -- *** Back-end function for code generation + , DefunctionalizedCodeOutput(..) + -- *** Back-end functions for assembly + , DefunctionalizedPostHscPipeline(..) + , DefunctionalizedAssemblerProg(..) + , DefunctionalizedAssemblerInfoGetter(..) + -- *** Other back-end functions + , DefunctionalizedCDefs(..) + -- ** Names of back ends (for API clients of version 9.4 or earlier) + , BackendName + + + + -- * Properties of back ends + , backendDescription + , backendWritesFiles + , backendPipelineOutput + , backendCanReuseLoadedCode + , backendGeneratesCode + , backendGeneratesCodeForHsBoot + , backendSupportsInterfaceWriting + , backendRespectsSpecialise + , backendWantsGlobalBindings + , backendHasNativeSwitch + , backendPrimitiveImplementation + , backendSimdValidity + , backendSupportsEmbeddedBlobs + , backendNeedsPlatformNcgSupport + , backendSupportsUnsplitProcPoints + , backendSwappableWithViaC + , backendUnregisterisedAbiOnly + , backendGeneratesHc + , backendSptIsDynamic + , backendWantsBreakpointTicks + , backendForcesOptimization0 + , backendNeedsFullWays + , backendSpecialModuleSource + , backendSupportsHpc + , backendSupportsCImport + , backendSupportsCExport + , backendAssemblerProg + , backendAssemblerInfoGetter + , backendCDefs + , backendCodeOutput + , backendUseJSLinker + , backendPostHscPipeline + , backendNormalSuccessorPhase + , backendName + , backendValidityOfCImport + , backendValidityOfCExport + + -- * Other functions of back ends + , platformDefaultBackend + , platformNcgSupported + ) + +where + + +import GHC.Prelude + +import GHC.Driver.Backend.Internal (BackendName(..)) +import GHC.Driver.Phases + + +import GHC.Utils.Error +import GHC.Utils.Panic + +import GHC.Driver.Pipeline.Monad +import GHC.Platform + + +--------------------------------------------------------------------------------- +-- +-- DESIGN CONSIDERATIONS +-- +-- +-- +-- The `Backend` type is made abstract in order to make it possible to +-- add new back ends without having to inspect or modify much code +-- elsewhere in GHC. Adding a new back end would be /easiest/ if +-- `Backend` were represented as a record type, but in peer review, +-- the clear will of the majority was to use a sum type. As a result, +-- when adding a new back end it is necessary to modify /every/ +-- function in this module that expects `Backend` as its first argument. +-- **By design, these functions have no default/wildcard cases.** This +-- design forces the author of a new back end to consider the semantics +-- in every case, rather than relying on a default that may be wrong. +-- The names and documentation of the functions defined in the `Backend` +-- record are sufficiently descriptive that the author of a new back +-- end will be able to identify correct result values without having to go +-- spelunking throughout the compiler. +-- +-- While the design localizes /most/ back-end logic in this module, +-- the author of a new back end will still have to make changes +-- elsewhere in the compiler: +-- +-- * For reasons described in Note [Backend Defunctionalization], +-- code-generation and post-backend pipeline functions, among other +-- functions, cannot be placed in the `Backend` record itself. +-- Instead, the /names/ of those functions are placed. Each name is +-- a value constructor in one of the algebraic data types defined in +-- this module. The named function is then defined near its point +-- of use. +-- +-- The author of a new back end will have to consider whether an +-- existing function will do or whether a new function needs to be +-- defined. When a new function needs to be defined, the author +-- must take two steps: +-- +-- - Add a value constructor to the relevant data type here +-- in the `Backend` module +-- +-- - Add a case to the location in the compiler (there should be +-- exactly one) where the value constructors of the relevant +-- data type are used +-- +-- * When a new back end is defined, it's quite possible that the +-- compiler driver will have to be changed in some way. Just because +-- the driver supports five back ends doesn't mean it will support a sixth +-- without changes. +-- +-- The collection of functions exported from this module hasn't +-- really been "designed"; it's what emerged from a refactoring of +-- older code. The real design criterion was "make it crystal clear +-- what has to be done to add a new back end." +-- +-- One issue remains unresolved: some of the error messages and +-- warning messages used in the driver assume a "closed world": they +-- think they know all the back ends that exist, and they are not shy +-- about enumerating them. Just one set of error messages has been +-- ported to have an open-world assumption: these are the error +-- messages associated with type checking of foreign imports and +-- exports. To allow other errors to be issued with an open-world +-- assumption, use functions `backendValidityOfCImport` and +-- `backendValidityOfCExport` as models, and have a look at how the +-- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and +-- "GHC.Tc.Errors.Ppr" +-- +--------------------------------------------------------------------------------- + + +platformDefaultBackend :: Platform -> Backend +platformDefaultBackend platform = if + | platformUnregisterised platform -> viaCBackend + | platformNcgSupported platform -> ncgBackend + | platformJSSupported platform -> jsBackend + | otherwise -> llvmBackend + +-- | Is the platform supported by the Native Code Generator? +platformNcgSupported :: Platform -> Bool +platformNcgSupported platform = if + | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI + | ncgValidArch -> True + | otherwise -> False + where + ncgValidArch = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchPPC -> True + ArchPPC_64 {} -> True + ArchAArch64 -> True + ArchWasm32 -> True + _ -> False + +-- | Is the platform supported by the JS backend? +platformJSSupported :: Platform -> Bool +platformJSSupported platform + | platformArch platform == ArchJavaScript = True + | otherwise = False + + +-- | A value of type @Backend@ represents one of GHC's back ends. +-- The set of back ends cannot be extended except by modifying the +-- definition of @Backend@ in this module. +-- +-- The @Backend@ type is abstract; that is, its value constructors are +-- not exported. It's crucial that they not be exported, because a +-- value of type @Backend@ carries only the back end's /name/, not its +-- behavior or properties. If @Backend@ were not abstract, then code +-- elsewhere in the compiler could depend directly on the name, not on +-- the semantics, which would make it challenging to create a new back end. +-- Because @Backend@ /is/ abstract, all the obligations of a new back +-- end are enumerated in this module, in the form of functions that +-- take @Backend@ as an argument. +-- +-- The issue of abstraction is discussed at great length in #20927 and !7442. + + +newtype Backend = Named BackendName + -- Must be a newtype so that it has no `Eq` instance and + -- a different `Show` instance. + +-- | The Show instance is for messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. + +instance Show Backend where + show = backendDescription + + +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend + :: Backend + +-- | The native code generator. +-- Compiles Cmm code into textual assembler, then relies on +-- an external assembler toolchain to produce machine code. +-- +-- Only supports a few platforms (X86, PowerPC, SPARC). +-- +-- See "GHC.CmmToAsm". +ncgBackend = Named NCG + +-- | The LLVM backend. +-- +-- Compiles Cmm code into LLVM textual IR, then relies on +-- LLVM toolchain to produce machine code. +-- +-- It relies on LLVM support for the calling convention used +-- by the NCG backend to produce code objects ABI compatible +-- with it (see "cc 10" or "ghccc" calling convention in +-- https://llvm.org/docs/LangRef.html#calling-conventions). +-- +-- Supports a few platforms (X86, AArch64, s390x, ARM). +-- +-- See "GHC.CmmToLlvm" +llvmBackend = Named LLVM + +-- | The JavaScript Backend +-- +-- See documentation in GHC.StgToJS +jsBackend = Named JavaScript + +-- | Via-C ("unregisterised") backend. +-- +-- Compiles Cmm code into C code, then relies on a C compiler +-- to produce machine code. +-- +-- It produces code objects that are /not/ ABI compatible +-- with those produced by NCG and LLVM backends. +-- +-- Produced code is expected to be less efficient than the +-- one produced by NCG and LLVM backends because STG +-- registers are not pinned into real registers. On the +-- other hand, it supports more target platforms (those +-- having a valid C toolchain). +-- +-- See "GHC.CmmToC" +viaCBackend = Named ViaC + +-- | The ByteCode interpreter. +-- +-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that +-- can be interpreted. It is used by GHCi. +-- +-- Currently some extensions are not supported +-- (foreign primops). +-- +-- See "GHC.StgToByteCode" +interpreterBackend = Named Interpreter + +-- | A dummy back end that generates no code. +-- +-- Use this back end to disable code generation. It is particularly +-- useful when GHC is used as a library for other purpose than +-- generating code (e.g. to generate documentation with Haddock) or +-- when the user requested it (via `-fno-code`) for some reason. +noBackend = Named NoBackend + +--------------------------------------------------------------------------------- + + + + +-- | This enumeration type specifies how the back end wishes GHC's +-- primitives to be implemented. (Module "GHC.StgToCmm.Prim" provides +-- a generic implementation of every primitive, but some primitives, +-- like `IntQuotRemOp`, can be implemented more efficiently by +-- certain back ends on certain platforms. For example, by using a +-- machine instruction that simultaneously computes quotient and remainder.) +-- +-- For the meaning of each alternative, consult +-- "GHC.StgToCmm.Config". (In a perfect world, type +-- `PrimitiveImplementation` would be defined there, in the module +-- that determines its meaning. But I could not figure out how to do +-- it without mutual recursion across module boundaries.) + +data PrimitiveImplementation + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | JSPrimitives -- ^ Primitives supported by JS backend + | GenericPrimitives -- ^ Primitives supported by all back ends + deriving Show + + +-- | Names a function that runs the assembler, of this type: +-- +-- > Logger -> DynFlags -> Platform -> [Option] -> IO () +-- +-- The functions so named are defined in "GHC.Driver.Pipeline.Execute". + +data DefunctionalizedAssemblerProg + = StandardAssemblerProg + -- ^ Use the standard system assembler + | JSAssemblerProg + -- ^ JS Backend compile to JS via Stg, and so does not use any assembler + | DarwinClangAssemblerProg + -- ^ If running on Darwin, use the assembler from the @clang@ + -- toolchain. Otherwise use the standard system assembler. + + + +-- | Names a function that discover from what toolchain the assembler +-- is coming, of this type: +-- +-- > Logger -> DynFlags -> Platform -> IO CompilerInfo +-- +-- The functions so named are defined in "GHC.Driver.Pipeline.Execute". + +data DefunctionalizedAssemblerInfoGetter + = StandardAssemblerInfoGetter + -- ^ Interrogate the standard system assembler + | JSAssemblerInfoGetter + -- ^ If using the JS backend; return 'Emscripten' + | DarwinClangAssemblerInfoGetter + -- ^ If running on Darwin, return `Clang`; otherwise + -- interrogate the standard system assembler. + + +-- | Names a function that generates code and writes the results to a +-- file, of this type: +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +-- +-- The functions so named are defined in "GHC.Driver.CodeOutput". +-- +-- We expect one function per back end—or more precisely, one function +-- for each back end that writes code to a file. (The interpreter +-- does not write to files; its output lives only in memory.) + +data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + | JSCodeOutput + + +-- | Names a function that tells the driver what should happen after +-- assembly code is written. This might include running a C compiler, +-- running LLVM, running an assembler, or various similar activities. +-- The function named normally has this type: +-- +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +-- +-- The functions so named are defined in "GHC.Driver.Pipeline". + +data DefunctionalizedPostHscPipeline + = NcgPostHscPipeline + | ViaCPostHscPipeline + | LlvmPostHscPipeline + | JSPostHscPipeline + | NoPostHscPipeline -- ^ After code generation, nothing else need happen. + +-- | Names a function that tells the driver what command-line options +-- to include when invoking a C compiler. It's meant for @-D@ options that +-- define symbols for the C preprocessor. Because the exact symbols +-- defined might depend on versions of tools located in the file +-- system (/cough/ LLVM /cough/), the function requires an `IO` action. +-- The function named has this type: +-- +-- > Logger -> DynFlags -> IO [String] + +data DefunctionalizedCDefs + = NoCDefs -- ^ No additional command-line options are needed + + | LlvmCDefs -- ^ Return command-line options that tell GHC about the + -- LLVM version. + +--------------------------------------------------------------------------------- + + + +-- | An informal description of the back end, for use in +-- issuing warning messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. +backendDescription :: Backend -> String +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named JavaScript) = "compiling to JavaScript" +backendDescription (Named Interpreter) = "byte-code interpreter" +backendDescription (Named NoBackend) = "no code generated" + +-- | This flag tells the compiler driver whether the back +-- end will write files: interface files and object files. +-- It is typically true for "real" back ends that generate +-- code into the filesystem. (That means, not the interpreter.) +backendWritesFiles :: Backend -> Bool +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named JavaScript) = True +backendWritesFiles (Named Interpreter) = False +backendWritesFiles (Named NoBackend) = False + +-- | When the back end does write files, this value tells +-- the compiler in what manner of file the output should go: +-- temporary, persistent, or specific. +backendPipelineOutput :: Backend -> PipelineOutput +backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named LLVM) = Persistent +backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named JavaScript) = Persistent +backendPipelineOutput (Named Interpreter) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile + +-- | This flag tells the driver whether the back end can +-- reuse code (bytecode or object code) that has been +-- loaded dynamically. Likely true only of the interpreter. +backendCanReuseLoadedCode :: Backend -> Bool +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named JavaScript) = False +backendCanReuseLoadedCode (Named Interpreter) = True +backendCanReuseLoadedCode (Named NoBackend) = False + +-- | It is is true of every back end except @-fno-code@ +-- that it "generates code." Surprisingly, this property +-- influences the driver in a ton of ways. Some examples: +-- +-- * If the back end does not generate code, then the +-- driver needs to turn on code generation for +-- Template Haskell (because that code needs to be +-- generated and run at compile time). +-- +-- * If the back end does not generate code, then the +-- driver does not need to deal with an output file. +-- +-- * If the back end /does/ generated code, then the +-- driver supports `HscRecomp`. If not, recompilation +-- does not need a linkable (and is automatically up +-- to date). +-- +backendGeneratesCode :: Backend -> Bool +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named JavaScript) = True +backendGeneratesCode (Named Interpreter) = True +backendGeneratesCode (Named NoBackend) = False + +backendGeneratesCodeForHsBoot :: Backend -> Bool +backendGeneratesCodeForHsBoot (Named NCG) = True +backendGeneratesCodeForHsBoot (Named LLVM) = True +backendGeneratesCodeForHsBoot (Named ViaC) = True +backendGeneratesCodeForHsBoot (Named JavaScript) = True +backendGeneratesCodeForHsBoot (Named Interpreter) = False +backendGeneratesCodeForHsBoot (Named NoBackend) = False + +-- | When set, this flag turns on interface writing for +-- Backpack. It should probably be the same as +-- `backendGeneratesCode`, but it is kept distinct for +-- reasons described in Note [-fno-code mode]. +backendSupportsInterfaceWriting :: Backend -> Bool +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named JavaScript) = True +backendSupportsInterfaceWriting (Named Interpreter) = True +backendSupportsInterfaceWriting (Named NoBackend) = False + +-- | When preparing code for this back end, the type +-- checker should pay attention to SPECIALISE pragmas. If +-- this flag is `False`, then the type checker ignores +-- SPECIALISE pragmas (for imported things?). +backendRespectsSpecialise :: Backend -> Bool +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named JavaScript) = True +backendRespectsSpecialise (Named Interpreter) = False +backendRespectsSpecialise (Named NoBackend) = False + +-- | This back end wants the `mi_globals` field of a +-- `ModIface` to be populated (with the top-level bindings +-- of the original source). True for the interpreter, and +-- also true for "no backend", which is used by Haddock. +-- (After typechecking a module, Haddock wants access to +-- the module's `GlobalRdrEnv`.) +backendWantsGlobalBindings :: Backend -> Bool +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named JavaScript) = False +backendWantsGlobalBindings (Named Interpreter) = True +backendWantsGlobalBindings (Named NoBackend) = True + +-- | The back end targets a technology that implements +-- `switch` natively. (For example, LLVM or C.) Therefore +-- it is not necessary for GHC to ccompile a Cmm `Switch` +-- form into a decision tree with jump tables at the +-- leaves. +backendHasNativeSwitch :: Backend -> Bool +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named JavaScript) = True +backendHasNativeSwitch (Named Interpreter) = False +backendHasNativeSwitch (Named NoBackend) = False + +-- | As noted in the documentation for +-- `PrimitiveImplementation`, certain primitives have +-- multiple implementations, depending on the capabilities +-- of the back end. This field signals to module +-- "GHC.StgToCmm.Prim" what implementations to use with +-- this back end. +backendPrimitiveImplementation :: Backend -> PrimitiveImplementation +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named JavaScript) = JSPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives + +-- | When this value is `IsValid`, the back end is +-- compatible with vector instructions. When it is +-- `NotValid`, it carries a message that is shown to +-- users. +backendSimdValidity :: Backend -> Validity' String +backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named LLVM) = IsValid +backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] + +-- | This flag says whether the back end supports large +-- binary blobs. See Note [Embedding large binary blobs] +-- in "GHC.CmmToAsm.Ppr". +backendSupportsEmbeddedBlobs :: Backend -> Bool +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named JavaScript) = False +backendSupportsEmbeddedBlobs (Named Interpreter) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False + +-- | This flag tells the compiler driver that the back end +-- does not support every target platform; it supports +-- only platforms that claim NCG support. (It's set only +-- for the native code generator.) Crufty. If the driver +-- tries to use the native code generator /without/ +-- platform support, the driver fails over to the LLVM +-- back end. +backendNeedsPlatformNcgSupport :: Backend -> Bool +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named JavaScript) = False +backendNeedsPlatformNcgSupport (Named Interpreter) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False + +-- | This flag is set if the back end can generate code +-- for proc points. If the flag is not set, then a Cmm +-- pass needs to split proc points (that is, turn each +-- proc point into a standalone procedure). +backendSupportsUnsplitProcPoints :: Backend -> Bool +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named JavaScript) = False +backendSupportsUnsplitProcPoints (Named Interpreter) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False + +-- | This flag guides the driver in resolving issues about +-- API support on the target platform. If the flag is set, +-- then these things are true: +-- +-- * When the target platform supports /only/ an unregisterised API, +-- this backend can be replaced with compilation via C. +-- +-- * When the target does /not/ support an unregisterised API, +-- this back end can replace compilation via C. +-- +backendSwappableWithViaC :: Backend -> Bool +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named JavaScript) = False +backendSwappableWithViaC (Named Interpreter) = False +backendSwappableWithViaC (Named NoBackend) = False + +-- | This flag is true if the back end works *only* with +-- the unregisterised ABI. +backendUnregisterisedAbiOnly :: Backend -> Bool +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named JavaScript) = False +backendUnregisterisedAbiOnly (Named Interpreter) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False + +-- | This flag is set if the back end generates C code in +-- a @.hc@ file. The flag lets the compiler driver know +-- if the command-line flag @-C@ is meaningful. +backendGeneratesHc :: Backend -> Bool +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named JavaScript) = False +backendGeneratesHc (Named Interpreter) = False +backendGeneratesHc (Named NoBackend) = False + +-- | This flag says whether SPT (static pointer table) +-- entries will be inserted dynamically if needed. If +-- this flag is `False`, then "GHC.Iface.Tidy" should emit C +-- stubs that initialize the SPT entries. +backendSptIsDynamic :: Backend -> Bool +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named JavaScript) = False +backendSptIsDynamic (Named Interpreter) = True +backendSptIsDynamic (Named NoBackend) = False + +-- | If this flag is set, then "GHC.HsToCore.Ticks" +-- inserts `Breakpoint` ticks. Used only for the +-- interpreter. +backendWantsBreakpointTicks :: Backend -> Bool +backendWantsBreakpointTicks (Named NCG) = False +backendWantsBreakpointTicks (Named LLVM) = False +backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named JavaScript) = False +backendWantsBreakpointTicks (Named Interpreter) = True +backendWantsBreakpointTicks (Named NoBackend) = False + +-- | If this flag is set, then the driver forces the +-- optimization level to 0, issuing a warning message if +-- the command line requested a higher optimization level. +backendForcesOptimization0 :: Backend -> Bool +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named JavaScript) = False +backendForcesOptimization0 (Named Interpreter) = True +backendForcesOptimization0 (Named NoBackend) = False + +-- | I don't understand exactly how this works. But if +-- this flag is set *and* another condition is met, then +-- @ghc/Main.hs@ will alter the `DynFlags` so that all the +-- `hostFullWays` are asked for. It is set only for the interpreter. +backendNeedsFullWays :: Backend -> Bool +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named JavaScript) = False +backendNeedsFullWays (Named Interpreter) = True +backendNeedsFullWays (Named NoBackend) = False + +-- | This flag is also special for the interpreter: if a +-- message about a module needs to be shown, do we know +-- anything special about where the module came from? The +-- Boolean argument is a `recomp` flag. +backendSpecialModuleSource :: Backend -> Bool -> Maybe String +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named JavaScript) = const Nothing +backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") + +-- | This flag says whether the back end supports Haskell +-- Program Coverage (HPC). If not, the compiler driver +-- will ignore the `-fhpc` option (and will issue a +-- warning message if it is used). +backendSupportsHpc :: Backend -> Bool +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named JavaScript) = False +backendSupportsHpc (Named Interpreter) = False +backendSupportsHpc (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- import of C functions. ("Supports" means "does not +-- barf on," so @-fno-code@ supports foreign C imports.) +backendSupportsCImport :: Backend -> Bool +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named JavaScript) = True +backendSupportsCImport (Named Interpreter) = True +backendSupportsCImport (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- export of Haskell functions to C. +backendSupportsCExport :: Backend -> Bool +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named JavaScript) = True +backendSupportsCExport (Named Interpreter) = False +backendSupportsCExport (Named NoBackend) = True + +-- | This (defunctionalized) function runs the assembler +-- used on the code that is written by this back end. A +-- program determined by a combination of back end, +-- `DynFlags`, and `Platform` is run with the given +-- `Option`s. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> Platform -> [Option] -> IO () +-- @ +-- +-- This field is usually defaulted. +backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg +backendAssemblerProg (Named NCG) = StandardAssemblerProg +backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg +backendAssemblerProg (Named ViaC) = StandardAssemblerProg +backendAssemblerProg (Named JavaScript) = JSAssemblerProg +backendAssemblerProg (Named Interpreter) = StandardAssemblerProg +backendAssemblerProg (Named NoBackend) = StandardAssemblerProg + +-- | This (defunctionalized) function is used to retrieve +-- an enumeration value that characterizes the C/assembler +-- part of a toolchain. The function caches the info in a +-- mutable variable that is part of the `DynFlags`. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> Platform -> IO CompilerInfo +-- @ +-- +-- This field is usually defaulted. +backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter +backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter +backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named JavaScript) = JSAssemblerInfoGetter +backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter + +-- | When using this back end, it may be necessary or +-- advisable to pass some `-D` options to a C compiler. +-- This (defunctionalized) function produces those +-- options, if any. An IO action may be necessary in +-- order to interrogate external tools about what version +-- they are, for example. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> IO [String] +-- @ +-- +-- This field is usually defaulted. +backendCDefs :: Backend -> DefunctionalizedCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named JavaScript) = NoCDefs +backendCDefs (Named Interpreter) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs + +-- | This (defunctionalized) function generates code and +-- writes it to a file. The type of the function is +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +backendCodeOutput :: Backend -> DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named JavaScript) = JSCodeOutput +backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +backendUseJSLinker :: Backend -> Bool +backendUseJSLinker (Named NCG) = False +backendUseJSLinker (Named LLVM) = False +backendUseJSLinker (Named ViaC) = False +backendUseJSLinker (Named JavaScript) = True +backendUseJSLinker (Named Interpreter) = False +backendUseJSLinker (Named NoBackend) = False + +-- | This (defunctionalized) function tells the compiler +-- driver what else has to be run after code output. +-- The type of the function is +-- +-- > +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline +backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named JavaScript) = JSPostHscPipeline +backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline +backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline + +-- | Somewhere in the compiler driver, when compiling +-- Haskell source (as opposed to a boot file or a sig +-- file), it needs to know what to do with the code that +-- the `backendCodeOutput` writes to a file. This `Phase` +-- value gives instructions like "run the C compiler", +-- "run the assembler," or "run the LLVM Optimizer." +backendNormalSuccessorPhase :: Backend -> Phase +backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named LLVM) = LlvmOpt +backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named JavaScript) = StopLn +backendNormalSuccessorPhase (Named Interpreter) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn + +-- | Name of the back end, if any. Used to migrate legacy +-- clients of the GHC API. Code within the GHC source +-- tree should not refer to a back end's name. +backendName :: Backend -> BackendName +backendName (Named NCG) = NCG +backendName (Named LLVM) = LLVM +backendName (Named ViaC) = ViaC +backendName (Named JavaScript) = JavaScript +backendName (Named Interpreter) = Interpreter +backendName (Named NoBackend) = NoBackend + + + +-- | A list of all back ends. They are ordered as we wish them to +-- appear when they are enumerated in error messages. + +allBackends :: [Backend] +allBackends = [ ncgBackend + , llvmBackend + , viaCBackend + , jsBackend + , interpreterBackend + , noBackend + ] + +-- | When foreign C import or export is invalid, the carried value +-- enumerates the /valid/ back ends. + +backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend] + +backendValidityOfCImport backend = + if backendSupportsCImport backend then + IsValid + else + NotValid $ filter backendSupportsCImport allBackends + +backendValidityOfCExport backend = + if backendSupportsCExport backend then + IsValid + else + NotValid $ filter backendSupportsCExport allBackends + + + + +{- +Note [Backend Defunctionalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I had hoped to include code-output and post-hsc-pipeline functions +directly in the `Backend` record itself. But this agenda was derailed +by mutual recursion in the types: + + - A `DynFlags` record contains a back end of type `Backend`. + - A `Backend` contains a code-output function. + - A code-output function takes Cmm as input. + - Cmm can include a `CLabel`. + - A `CLabel` can have elements that are defined in + `GHC.Driver.Session`, where `DynFlags` is defined. + +There is also a nasty issue in the values: a typical post-backend +pipeline function both depends on and is depended upon by functions in +"GHC.Driver.Pipeline". + +I'm cut the Gordian not by removing the function types from the +`Backend` record. Instead, a function is represented by its /name/. +This representation is an example of an old trick called +/defunctionalization/, which has been used in both compilers and +interpreters for languages with first-class, nested functions. Here, +a function's name is a value of an algebraic data type. For example, +a code-output function is represented by a value of this type: + + data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + +Such a function may be applied in one of two ways: + + - In this particular example, a `case` expression in module + "GHC.Driver.CodeOutput" discriminates on the value and calls the + designated function. + + - In another example, a function of type `DefunctionalizedCDefs` is + applied by calling function `applyCDefs`, which has this type: + + @ + applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] + @ + + Function `applyCDefs` is defined in module "GHC.SysTools.Cpp". + +I don't love this solution, but defunctionalization is a standard +thing, and it makes the meanings of the enumeration values clear. + +Anyone defining a new back end will need to extend both the +`DefunctionalizedCodeOutput` type and the corresponding apply +function. +-} diff --git a/compiler/GHC/Driver/Backend/Internal.hs b/compiler/GHC/Driver/Backend/Internal.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Backend/Internal.hs @@ -0,0 +1,33 @@ +{-| +Module : GHC.Driver.Backend.Internal +Description : Interface for migrating legacy clients of the GHC API + +In versions of GHC up through 9.2, a `Backend` was represented only by +its name. This module is meant to aid clients written against the GHC +API, versions 9.2 and older. The module provides an alternative way +to name any back end found in GHC 9.2. /Code within the GHC source +tree should not import this module./ (#20927). + +Only back ends found in version 9.2 have names. + +-} + +module GHC.Driver.Backend.Internal + ( -- * Name of a back end + BackendName(..) + ) + +where + + + +import GHC.Prelude + +data BackendName + = NCG -- ^ Names the native code generator backend. + | LLVM -- ^ Names the LLVM backend. + | ViaC -- ^ Names the Via-C backend. + | JavaScript -- ^ Names the JS backend. + | Interpreter -- ^ Names the ByteCode interpreter. + | NoBackend -- ^ Names the `-fno-code` backend. + deriving (Eq, Show) diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -23,7 +23,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Unit.Module.Name import GHC.Unit.Types import GHC.Unit.Info @@ -65,7 +64,7 @@ -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n - = DeclD HscSource (Located ModuleName) (Located HsModule) + = DeclD HscSource (Located ModuleName) (Located (HsModule GhcPs)) | IncludeD (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n) diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- @@ -38,7 +39,7 @@ import GHC.ResponseFile import Control.Exception (IOException, catch) -import Control.Monad (liftM, ap) +import Control.Monad (ap) import Control.Monad.IO.Class -------------------------------------------------------- @@ -138,9 +139,7 @@ newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg -> Errs -> Warns -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (EwM m) where pure v = EwM (\_ e w -> return (e, w, v)) diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -29,6 +29,7 @@ initSimpleOpts dflags = SimpleOpts { so_uf_opts = unfoldingOpts dflags , so_co_opts = initOptCoercionOpts dflags + , so_eta_red = gopt Opt_DoEtaReduction dflags } -- | Extract BCO options from DynFlags diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/Core/Lint.hs @@ -0,0 +1,182 @@ +module GHC.Driver.Config.Core.Lint + ( endPass + , endPassHscEnvIO + , lintCoreBindings + , initEndPassConfig + , initLintPassResultConfig + , initLintConfig + ) where + +import GHC.Prelude + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic + +import GHC.Core +import GHC.Core.Lint +import GHC.Core.Lint.Interactive +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify.Env ( SimplMode(..) ) +import GHC.Core.Opt.Monad +import GHC.Core.Coercion + +import GHC.Types.Basic ( CompilerPhase(..) ) + +import GHC.Utils.Outputable as Outputable + +{- +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; name_ppr_ctx <- getNamePprCtx + ; liftIO $ endPassHscEnvIO hsc_env + name_ppr_ctx pass binds rules + } + +endPassHscEnvIO :: HscEnv -> NamePprCtx + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules + = do { let dflags = hsc_dflags hsc_env + ; endPassIO + (hsc_logger hsc_env) + (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass) + binds rules + } + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs +lintCoreBindings dflags coreToDo vars -- binds + = lintCoreBindings' $ LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = perPassFlags dflags coreToDo + , l_vars = vars + } + +initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig +initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig + { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) + , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags + then Just $ initLintPassResultConfig dflags extra_vars pass + else Nothing + , ep_namePprCtx = name_ppr_ctx + , ep_dumpFlag = coreDumpFlag pass + , ep_prettyPass = ppr pass + , ep_passDetails = pprPassDetails pass + } + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_stranal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreAddCallerCcs = Nothing +coreDumpFlag CoreAddLateCcs = Nothing +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig +initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig + { lpr_diagOpts = initDiagOpts dflags + , lpr_platform = targetPlatform dflags + , lpr_makeLintFlags = perPassFlags dflags pass + , lpr_showLintWarnings = showLintWarnings pass + , lpr_passPpr = ppr pass + , lpr_localsInScope = extra_vars + } + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of + InitialPhase -> False + _ -> True +showLintWarnings _ = True + +perPassFlags :: DynFlags -> CoreToDo -> LintFlags +perPassFlags dflags pass + = (defaultLintFlags dflags) + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs + , lf_check_linearity = check_linearity + , lf_check_fixed_rep = check_fixed_rep } + where + -- In the output of the desugarer, before optimisation, + -- we have eta-expanded data constructors with representation-polymorphic + -- bindings; so we switch off the representation-polymorphism checks. + -- The very simple optimiser will beta-reduce them away. + -- See Note [Checking for representation-polymorphic built-ins] + -- in GHC.HsToCore.Expr. + check_fixed_rep = case pass of + CoreDesugar -> False + _ -> True + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + -- See Note [Linting linearity] + check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( + case pass of + CoreDesugar -> True + _ -> False) + +initLintConfig :: DynFlags -> [Var] -> LintConfig +initLintConfig dflags vars =LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = defaultLintFlags dflags + , l_vars = vars + } + +defaultLintFlags :: DynFlags -> LintFlags +defaultLintFlags dflags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags + , lf_report_unsat_syns = True + , lf_check_fixed_rep = True + } diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs --- a/compiler/GHC/Driver/Config/Diagnostic.hs +++ b/compiler/GHC/Driver/Config/Diagnostic.hs @@ -1,5 +1,13 @@ + +-- | Functions for initialising error message printing configuration from the +-- GHC session flags. module GHC.Driver.Config.Diagnostic ( initDiagOpts + , initPrintConfig + , initPsMessageOpts + , initDsMessageOpts + , initTcMessageOpts + , initDriverMessageOpts ) where @@ -8,7 +16,16 @@ import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) +import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..)) +import GHC.Driver.Errors.Ppr () +import GHC.Tc.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Types.Error +import GHC.Tc.Errors.Ppr +-- | Initialise the general configuration for printing diagnostic messages +-- For example, this configuration controls things like whether warnings are +-- treated like errors. initDiagOpts :: DynFlags -> DiagOpts initDiagOpts dflags = DiagOpts { diag_warning_flags = warningFlags dflags @@ -18,4 +35,24 @@ , diag_max_errors = maxErrors dflags , diag_ppr_ctx = initSDocContext dflags defaultErrStyle } + +-- | Initialise the configuration for printing specific diagnostic messages +initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage +initPrintConfig dflags = + GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags + , tcMessageOpts = initTcMessageOpts dflags + , dsMessageOpts = initDsMessageOpts dflags + , driverMessageOpts= initDriverMessageOpts dflags } + +initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage +initPsMessageOpts _ = NoDiagnosticOpts + +initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage +initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags } + +initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage +initDsMessageOpts _ = NoDiagnosticOpts + +initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) diff --git a/compiler/GHC/Driver/Config/Logger.hs b/compiler/GHC/Driver/Config/Logger.hs --- a/compiler/GHC/Driver/Config/Logger.hs +++ b/compiler/GHC/Driver/Config/Logger.hs @@ -23,7 +23,9 @@ , log_dump_dir = dumpDir dflags , log_dump_prefix = dumpPrefix dflags , log_dump_prefix_override = dumpPrefixForce dflags + , log_with_ways = gopt Opt_DumpWithWays dflags , log_enable_debug = not (hasNoDebugOutput dflags) , log_verbosity = verbosity dflags + , log_ways = Just $ ways dflags } diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -14,6 +14,7 @@ , hsc_all_home_unit_ids , hscUpdateLoggerFlags , hscUpdateHUG + , hscUpdateHPT_lazy , hscUpdateHPT , hscSetActiveHomeUnit , hscSetActiveUnitId @@ -45,7 +46,7 @@ import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Diagnostic (initDiagOpts) +import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) import GHC.Runtime.Context @@ -80,7 +81,6 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Logger -import GHC.Utils.Trace import Data.IORef import qualified Data.Set as Set @@ -94,7 +94,8 @@ (a, w) <- hsc hsc_env emptyMessages let dflags = hsc_dflags hsc_env let !diag_opts = initDiagOpts dflags - printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w + !print_config = initPrintConfig dflags + printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w return a runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage) @@ -133,8 +134,15 @@ hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG +hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT_lazy f hsc_env = + let !res = updateHpt_lazy f (hsc_unit_env hsc_env) + in hsc_env { hsc_unit_env = res } + hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) } +hscUpdateHPT f hsc_env = + let !res = updateHpt f (hsc_unit_env hsc_env) + in hsc_env { hsc_unit_env = res } hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } diff --git a/compiler/GHC/Driver/Env/KnotVars.hs b/compiler/GHC/Driver/Env/KnotVars.hs --- a/compiler/GHC/Driver/Env/KnotVars.hs +++ b/compiler/GHC/Driver/Env/KnotVars.hs @@ -57,7 +57,7 @@ the data structure in 'mkDsEnvs' which required this generalised structure. In interactive mode the TypeEnvs from all the previous statements are merged -togethed into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal +together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal lookup functions either look in the HPT or EPS but there is no entry for the `Ghci` modules in either, so the whole merged TypeEnv for all previous Ghci* is stored in the `if_rec_types` variable and then lookup checks there in the case of any interactive module. @@ -71,7 +71,7 @@ Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate at a particular time, apart from one case, when constructing the in-scope set -when linting an unfolding. In this case the whole environemnt is needed to tell us +when linting an unfolding. In this case the whole environment is needed to tell us everything that's in-scope at top-level in the loop because whilst we are linting unfoldings the top-level identifiers from modules in the cycle might not be globalised properly yet. @@ -89,7 +89,7 @@ This invariant is difficult to test but easy to check using ghc-debug. The usage of NoKnotVars is intended to make this invariant easier to check. -The most common situation where a KnotVars is retained accidently is if a HscEnv +The most common situation where a KnotVars is retained accidentally is if a HscEnv which contains reference to a KnotVars is used during interface file loading. The thunks created during this process will retain a reference to the KnotVars. In theory, all these references should be removed by 'maybeRehydrateAfter' as that rehydrates all diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -8,6 +8,8 @@ import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) + import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) @@ -106,4 +108,7 @@ , hsc_tmpfs :: !TmpFs -- ^ Temporary files + + , hsc_llvm_config :: !LlvmConfigCache + -- ^ LLVM configuration cache. } diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( printOrThrowDiagnostics , printMessages @@ -16,47 +17,48 @@ import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine -printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO () -printMessages logger opts msgs - = sequence_ [ let style = mkErrStyle unqual +printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () +printMessages logger msg_opts opts msgs + = sequence_ [ let style = mkErrStyle name_ppr_ctx ctx = (diag_ppr_ctx opts) { sdocStyle = style } - in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $ + in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ withPprStyle style (messageWithHints ctx dia) - | MsgEnvelope { errMsgSpan = s, + | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, - errMsgSeverity = sev, - errMsgContext = unqual } <- sortMsgBag (Just opts) - (getMessages msgs) ] + errMsgSeverity = sev, + errMsgContext = name_ppr_ctx } + <- sortMsgBag (Just opts) (getMessages msgs) ] where messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc messageWithHints ctx e = - let main_msg = formatBulleted ctx $ diagnosticMessage e + let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e in case diagnosticHints e of [] -> main_msg [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted ctx . mkDecorated . map ppr $ hs) -handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO () -handleFlagWarnings logger opts warns = do +handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO () +handleFlagWarnings logger print_config opts warns = do let -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. bag = listToBag [ mkPlainMsgEnvelope opts loc $ GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainDiagnostic reason noHints $ text warn | CmdLine.Warn reason (L loc warn) <- warns ] - printOrThrowDiagnostics logger opts (mkMessages bag) + printOrThrowDiagnostics logger print_config opts (mkMessages bag) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. -printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO () -printOrThrowDiagnostics logger opts msgs +printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO () +printOrThrowDiagnostics logger print_config opts msgs | errorsOrFatalWarningsFound msgs = throwErrors msgs | otherwise - = printMessages logger opts msgs + = printMessages logger print_config opts msgs -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it -- for dealing with parse errors when the driver is doing dependency analysis. diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} -module GHC.Driver.Errors.Ppr where +module GHC.Driver.Errors.Ppr ( + -- This module only exports Diagnostic instances. + ) where import GHC.Prelude @@ -13,6 +18,7 @@ import GHC.Parser.Errors.Ppr () import GHC.Tc.Errors.Ppr () import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module @@ -22,6 +28,8 @@ import Data.Version import Language.Haskell.Syntax.Decls (RuleDecl(..)) +import GHC.Tc.Errors.Types (TcRnMessage) +import GHC.HsToCore.Errors.Types (DsMessage) -- -- Suggestions @@ -32,19 +40,23 @@ suggestInstantiatedWith pi_mod_name insts = [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] - instance Diagnostic GhcMessage where - diagnosticMessage = \case + type DiagnosticOpts GhcMessage = GhcMessageOpts + defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) + (defaultDiagnosticOpts @TcRnMessage) + (defaultDiagnosticOpts @DsMessage) + (defaultDiagnosticOpts @DriverMessage) + diagnosticMessage opts = \case GhcPsMessage m - -> diagnosticMessage m + -> diagnosticMessage (psMessageOpts opts) m GhcTcRnMessage m - -> diagnosticMessage m + -> diagnosticMessage (tcMessageOpts opts) m GhcDsMessage m - -> diagnosticMessage m + -> diagnosticMessage (dsMessageOpts opts) m GhcDriverMessage m - -> diagnosticMessage m - GhcUnknownMessage m - -> diagnosticMessage m + -> diagnosticMessage (driverMessageOpts opts) m + GhcUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m diagnosticReason = \case GhcPsMessage m @@ -70,12 +82,16 @@ GhcUnknownMessage m -> diagnosticHints m + diagnosticCode = constructorCode + instance Diagnostic DriverMessage where - diagnosticMessage = \case - DriverUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DriverMessage = DriverMessageOpts + defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) + diagnosticMessage opts = \case + DriverUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DriverPsHeaderMessage m - -> diagnosticMessage m + -> diagnosticMessage (psDiagnosticOpts opts) m DriverMissingHomeModules uid missing buildingCabalPackage -> let msg | buildingCabalPackage == YesBuildingCabalPackage = hang @@ -148,8 +164,8 @@ -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found") DriverUserDefinedRuleIgnored (HsRule { rd_name = n }) -> mkSimpleDecorated $ - text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ - text "User defined rules are disabled under Safe Haskell" + text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ + text "Defining user rules is disabled under Safe Haskell" DriverMixedSafetyImport modName -> mkSimpleDecorated $ text "Module" <+> ppr modName <+> text ("is imported both as a safe and unsafe import!") @@ -312,3 +328,5 @@ -> noHints DriverHomePackagesNotClosed {} -> noHints + + diagnosticCode = constructorCode diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Driver.Errors.Types ( GhcMessage(..) - , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage) + , GhcMessageOpts(..) + , DriverMessage(..) + , DriverMessageOpts(..) + , DriverMessages, PsMessage(PsHeaderMessage) , BuildingCabalPackage(..) , WarningMessages , ErrorMessages @@ -32,6 +37,8 @@ import Language.Haskell.Syntax.Decls (RuleDecl) +import GHC.Generics ( Generic ) + -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage @@ -83,16 +90,25 @@ -- 'Diagnostic' constraint ensures that worst case scenario we can still -- render this into something which can be eventually converted into a -- 'DecoratedSDoc'. - GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage + GhcUnknownMessage :: UnknownDiagnostic -> GhcMessage + deriving Generic + + +data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage + , tcMessageOpts :: DiagnosticOpts TcRnMessage + , dsMessageOpts :: DiagnosticOpts DsMessage + , driverMessageOpts :: DiagnosticOpts DriverMessage + } + -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also -- provided to ease the integration of #18516 by allowing diagnostics to be -- wrapped into the general (but structured) 'GhcMessage' type, so that the -- conversion can happen gradually. This function should not be needed within -- GHC, as it would typically be used by plugin or library authors (see -- comment for the 'GhcUnknownMessage' type constructor) -ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage -ghcUnknownMessage = GhcUnknownMessage +ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage +ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'. @@ -110,7 +126,8 @@ -- | A message from the driver. data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. - DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage + DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage + -- | A parse error in parsing a Haskell file header during dependency -- analysis DriverPsHeaderMessage :: !PsMessage -> DriverMessage @@ -350,6 +367,11 @@ DriverRedirectedNoMain :: !ModuleName -> DriverMessage DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + +deriving instance Generic DriverMessage + +data DriverMessageOpts = + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage } -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -1,5 +1,7 @@ module GHC.Driver.Flags ( DumpFlag(..) + , getDumpFlagFrom + , enabledIfVerbose , GeneralFlag(..) , Language(..) , optimisationFlags @@ -24,6 +26,7 @@ import GHC.Utils.Binary import GHC.Data.EnumSet as EnumSet +import Control.DeepSeq import Control.Monad (guard) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) @@ -38,6 +41,9 @@ put_ bh = put_ bh . fromEnum get bh = toEnum <$> get bh +instance NFData Language where + rnf x = x `seq` () + -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide] @@ -64,6 +70,7 @@ | Opt_D_dump_cmm_split | Opt_D_dump_cmm_info | Opt_D_dump_cmm_cps + | Opt_D_dump_cmm_thread_sanitizer -- end cmm subflags | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. | Opt_D_dump_asm @@ -75,6 +82,7 @@ | Opt_D_dump_asm_stats | Opt_D_dump_c_backend | Opt_D_dump_llvm + | Opt_D_dump_js | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds @@ -143,11 +151,52 @@ | Opt_D_faststring_stats deriving (Eq, Show, Enum) +-- | Helper function to query whether a given `DumpFlag` is enabled or not. +getDumpFlagFrom + :: (a -> Int) -- ^ Getter for verbosity setting + -> (a -> EnumSet DumpFlag) -- ^ Getter for the set of enabled dump flags + -> DumpFlag -> a -> Bool +getDumpFlagFrom getVerbosity getFlags f x + = (f `EnumSet.member` getFlags x) + || (getVerbosity x >= 4 && enabledIfVerbose f) + +-- | Is the flag implicitly enabled when the verbosity is high enough? +enabledIfVerbose :: DumpFlag -> Bool +enabledIfVerbose Opt_D_dump_tc_trace = False +enabledIfVerbose Opt_D_dump_rn_trace = False +enabledIfVerbose Opt_D_dump_cs_trace = False +enabledIfVerbose Opt_D_dump_if_trace = False +enabledIfVerbose Opt_D_dump_tc = False +enabledIfVerbose Opt_D_dump_rn = False +enabledIfVerbose Opt_D_dump_rn_stats = False +enabledIfVerbose Opt_D_dump_hi_diffs = False +enabledIfVerbose Opt_D_verbose_core2core = False +enabledIfVerbose Opt_D_verbose_stg2stg = False +enabledIfVerbose Opt_D_dump_splices = False +enabledIfVerbose Opt_D_th_dec_file = False +enabledIfVerbose Opt_D_dump_rule_firings = False +enabledIfVerbose Opt_D_dump_rule_rewrites = False +enabledIfVerbose Opt_D_dump_simpl_trace = False +enabledIfVerbose Opt_D_dump_rtti = False +enabledIfVerbose Opt_D_dump_inlinings = False +enabledIfVerbose Opt_D_dump_verbose_inlinings = False +enabledIfVerbose Opt_D_dump_core_stats = False +enabledIfVerbose Opt_D_dump_asm_stats = False +enabledIfVerbose Opt_D_dump_types = False +enabledIfVerbose Opt_D_dump_simpl_iterations = False +enabledIfVerbose Opt_D_dump_ticked = False +enabledIfVerbose Opt_D_dump_view_pattern_commoning = False +enabledIfVerbose Opt_D_dump_mod_cycles = False +enabledIfVerbose Opt_D_dump_mod_map = False +enabledIfVerbose Opt_D_dump_ec_trace = False +enabledIfVerbose _ = True + -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag -- See Note [Updating flag description in the User's Guide] = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_DumpWithWays -- ^ Use foo.ways. instead of foo. | Opt_D_dump_minimal_imports | Opt_DoCoreLinting | Opt_DoLinearCoreLinting @@ -176,6 +225,7 @@ | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances + | Opt_PrintRedundantPromotionTicks | Opt_PrintTypecheckerElaboration -- optimisation opts @@ -187,6 +237,11 @@ | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn + | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the + -- simplifier + | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the + -- top level in the simplifier + -- N.B. See Note [RHS Floating] | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively @@ -304,6 +359,7 @@ | Opt_Ticky_Dyn_Thunk | Opt_Ticky_Tag | Opt_Ticky_AP -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts + | Opt_CmmThreadSanitizer | Opt_RPath | Opt_RelativeDynlibPaths | Opt_CompactUnwind -- ^ @-fcompact-unwind@ @@ -314,7 +370,7 @@ | Opt_VersionMacros | Opt_WholeArchiveHsLibs -- copy all libs into a single folder prior to linking binaries - -- this should elivate the excessive command line limit restrictions + -- this should alleviate the excessive command line limit restrictions -- on windows, by only requiring a single -L argument instead of -- one for each dependency. At the time of this writing, gcc -- forwards all -L flags to the collect2 command without using a @@ -324,6 +380,7 @@ | Opt_KeepCAFs | Opt_KeepGoing | Opt_ByteCode + | Opt_ByteCodeAndObjectCode | Opt_LinkRts -- output style opts @@ -379,6 +436,9 @@ | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- Error message suppression + | Opt_ShowErrorContext + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -395,6 +455,8 @@ | Opt_KeepOFiles | Opt_BuildDynamicToo + | Opt_WriteIfSimplifiedCore + | Opt_UseBytecodeRatherThanObjects -- safe haskell flags | Opt_DistrustAllPackages @@ -566,6 +628,7 @@ | Opt_WarnGADTMonoLocalBinds -- Since 9.4 | Opt_WarnTypeEqualityOutOfScope -- Since 9.4 | Opt_WarnTypeEqualityRequiresOperators -- Since 9.4 + | Opt_WarnLoopySuperclassSolve -- Since 9.6 deriving (Eq, Ord, Show, Enum) -- | Return the names of a WarningFlag @@ -670,6 +733,7 @@ Opt_WarnUnicodeBidirectionalFormatCharacters -> "unicode-bidirectional-format-characters" :| [] Opt_WarnGADTMonoLocalBinds -> "gadt-mono-local-binds" :| [] Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| [] + Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| [] Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] -- ----------------------------------------------------------------------------- @@ -758,6 +822,7 @@ Opt_WarnUnrecognisedWarningFlags, Opt_WarnSimplifiableClassConstraints, Opt_WarnStarBinder, + Opt_WarnStarIsType, Opt_WarnInaccessibleCode, Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, @@ -766,6 +831,7 @@ Opt_WarnForallIdentifier, Opt_WarnUnicodeBidirectionalFormatCharacters, Opt_WarnGADTMonoLocalBinds, + Opt_WarnLoopySuperclassSolve, Opt_WarnTypeEqualityRequiresOperators ] @@ -799,7 +865,6 @@ Opt_WarnMissingPatternSynonymSignatures, Opt_WarnUnusedRecordWildcards, Opt_WarnRedundantRecordWildcards, - Opt_WarnStarIsType, Opt_WarnIncompleteUniPatterns, Opt_WarnIncompletePatternsRecUpd ] @@ -817,7 +882,6 @@ minusWcompatOpts = [ Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnStarIsType , Opt_WarnCompatUnqualifiedImports , Opt_WarnTypeEqualityOutOfScope ] diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -141,7 +141,7 @@ , runMetaHook :: !(Maybe (MetaHook TcM)) , linkHook :: !(Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)) - , runRnSpliceHook :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))) + , runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn))) , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) diff --git a/compiler/GHC/Driver/LlvmConfigCache.hs b/compiler/GHC/Driver/LlvmConfigCache.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/LlvmConfigCache.hs @@ -0,0 +1,26 @@ +-- | LLVM config cache +module GHC.Driver.LlvmConfigCache + ( LlvmConfigCache + , initLlvmConfigCache + , readLlvmConfigCache + ) +where + +import GHC.Prelude +import GHC.CmmToLlvm.Config + +import System.IO.Unsafe + +-- | Cache LLVM configuration read from files in top_dir +-- +-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config +-- +-- Currently implemented with unsafe lazy IO. But it could be implemented with +-- an IORef as the exposed interface is in IO. +data LlvmConfigCache = LlvmConfigCache LlvmConfig + +initLlvmConfigCache :: FilePath -> IO LlvmConfigCache +initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir) + +readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig +readLlvmConfigCache (LlvmConfigCache !config) = pure config diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -147,15 +147,16 @@ dflags <- getSessionDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printOrThrowDiagnostics logger diag_opts warns + !print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, -- e.g., to maintain additional state consider wrapping this monad or using -- 'GhcT'. newtype Ghc a = Ghc { unGhc :: Session -> IO a } - deriving (Functor) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO) -- | The Session is a handle to the complete state of a compilation -- session. A compilation session consists of a set of modules @@ -163,19 +164,6 @@ -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) -instance Applicative Ghc where - pure a = Ghc $ \_ -> return a - g <*> m = do f <- g; a <- m; return (f a) - -instance Monad Ghc where - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance MonadFix Ghc where - mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) - instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags @@ -213,22 +201,12 @@ -- -- Note that the wrapped monad must support IO and handling of exceptions. newtype GhcT m a = GhcT { unGhcT :: Session -> m a } - deriving (Functor) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m) liftGhcT :: m a -> GhcT m a liftGhcT m = GhcT $ \_ -> m -instance Applicative m => Applicative (GhcT m) where - pure x = GhcT $ \_ -> pure x - g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s - -instance Monad m => Monad (GhcT m) where - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) @@ -247,7 +225,8 @@ dflags <- getDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printMessages logger diag_opts (srcErrorMessages err) + !print_config = initPrintConfig dflags + liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m () diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -99,6 +99,7 @@ | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code | MergeForeign -- merge in the foreign object files + | Js -- pre-process Js source -- The final phase is a pseudo-phase that tells the pipeline to stop. | StopLn -- Stop, but linking will follow, so generate .o file @@ -134,6 +135,7 @@ eqPhase StopLn StopLn = True eqPhase Ccxx Ccxx = True eqPhase Cobjcxx Cobjcxx = True +eqPhase Js Js = True eqPhase _ _ = False -- MP: happensBefore is only used in preprocessPipeline, that usage should @@ -157,14 +159,15 @@ LlvmLlc -> LlvmMangle LlvmMangle -> As False As _ -> MergeForeign - Ccxx -> As False - Cc -> As False - Cobjc -> As False - Cobjcxx -> As False + Ccxx -> MergeForeign + Cc -> MergeForeign + Cobjc -> MergeForeign + Cobjcxx -> MergeForeign CmmCpp -> Cmm Cmm -> maybeHCc - HCc -> As False + HCc -> MergeForeign MergeForeign -> StopLn + Js -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised platform then HCc @@ -198,6 +201,7 @@ startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm +startPhase "js" = Js startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the @@ -226,10 +230,11 @@ phaseInputExt CmmCpp = "cmmcpp" phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" +phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -238,6 +243,7 @@ haskellish_suffixes = haskellish_src_suffixes ++ [ "hc", "cmm", "cmmcpp" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +js_suffixes = [ "js" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = @@ -259,13 +265,14 @@ _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes +isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool @@ -275,6 +282,7 @@ isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + || isJsSuffix suff || isBackpackishSuffix suff -- | When we are given files (modified by -x arguments) we need @@ -291,7 +299,7 @@ isHaskellishTarget (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, @@ -319,5 +327,5 @@ HCc -> Just LangC As _ -> Just LangAsm MergeForeign -> Just RawObject + Js -> Just LangJs _ -> Nothing - diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -16,11 +16,12 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation ) -import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Module.ModIface -import GHC.Linker.Types import GHC.Driver.Phases +import Language.Haskell.Syntax.Module.Name ( ModuleName ) +import GHC.Unit.Home.ModInfo + -- Typed Pipeline Phases -- MP: TODO: We need to refine the arguments to each of these phases so recompilation -- can be smarter. For example, rather than passing a whole HscEnv, just pass the options @@ -38,11 +39,13 @@ -> Messages GhcMessage -> Maybe Fingerprint -> TPhase HscBackendAction - T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath) + T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, HomeModLinkable, FilePath) T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) - T_Cc :: Phase -> PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -1,6 +1,13 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedTuples #-} +#endif + -- | Definitions for writing /plugins/ for GHC. Plugins can hook into -- several areas of the compiler. See the 'Plugin' type. These plugins -- include type-checker plugins, source plugins, and core-to-core plugins. @@ -14,6 +21,10 @@ , CommandLineOption , PsMessages(..) , ParsedResult(..) + + -- * External plugins + , loadExternalPlugins + -- ** Recompilation checking , purePlugin, impurePlugin, flagRecompile , PluginRecompile(..) @@ -52,6 +63,7 @@ , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' , LoadedPlugin(..), lpModuleName , StaticPlugin(..) + , ExternalPlugin(..) , mapPlugins, withPlugins, withPlugins_ ) where @@ -60,6 +72,7 @@ import GHC.Driver.Env import GHC.Driver.Monad import GHC.Driver.Phases +import GHC.Driver.Plugins.External import GHC.Unit.Module import GHC.Unit.Module.ModIface @@ -71,11 +84,16 @@ import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) -import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) +import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) +import GHC.Linker.Types +import GHC.Types.Unique.DFM + import GHC.Utils.Fingerprint -import GHC.Utils.Outputable (Outputable(..), text, (<+>)) +import GHC.Utils.Outputable +import GHC.Utils.Panic import Data.List (sort) @@ -84,9 +102,14 @@ import qualified Data.Semigroup import Control.Monad -import GHC.Linker.Types -import GHC.Types.Unique.DFM +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +import GHCi.ObjLink +import GHC.Exts (addrToAny#, Ptr(..)) +import GHC.Utils.Encoding +#endif + + -- | Command line options gathered from the -PModule.Name:stuff syntax -- are given to you as this type type CommandLineOption = String @@ -195,6 +218,14 @@ -- ^ the module containing the plugin } +-- | External plugin loaded directly from a library without loading module +-- interfaces +data ExternalPlugin = ExternalPlugin + { epPlugin :: PluginWithArgs -- ^ Plugin with its arguments + , epUnit :: String -- ^ UnitId + , epModule :: String -- ^ Module name + } + -- | A static plugin with its arguments. For registering compiled-in plugins -- through the GHC API. data StaticPlugin = StaticPlugin @@ -284,6 +315,10 @@ -- To add dynamically loaded plugins through the GHC API see -- 'addPluginModuleName' instead. + , externalPlugins :: ![ExternalPlugin] + -- ^ External plugins loaded directly from libraries without loading + -- module interfaces. + , loadedPlugins :: ![LoadedPlugin] -- ^ Plugins dynamically loaded after processing arguments. What -- will be loaded here is directed by DynFlags.pluginModNames. @@ -298,12 +333,17 @@ } emptyPlugins :: Plugins -emptyPlugins = Plugins [] [] ([], emptyUDFM) - +emptyPlugins = Plugins + { staticPlugins = [] + , externalPlugins = [] + , loadedPlugins = [] + , loadedPluginDeps = ([], emptyUDFM) + } pluginsWithArgs :: Plugins -> [PluginWithArgs] pluginsWithArgs plugins = map lpPlugin (loadedPlugins plugins) ++ + map epPlugin (externalPlugins plugins) ++ map spPlugin (staticPlugins plugins) -- | Perform an operation by using all of the plugins in turn. @@ -327,3 +367,53 @@ } defaultFrontendPlugin :: FrontendPlugin defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } + + +-- | Load external plugins +loadExternalPlugins :: [ExternalPluginSpec] -> IO [ExternalPlugin] +loadExternalPlugins [] = return [] +#if !defined(HAVE_INTERNAL_INTERPRETER) +loadExternalPlugins _ = do + panic "loadExternalPlugins: can't load external plugins with GHC built without internal interpreter" +#elif !defined(CAN_LOAD_DLL) +loadExternalPlugins _ = do + panic "loadExternalPlugins: loading shared libraries isn't supported by this compiler" +#else +loadExternalPlugins ps = do + -- initialize the linker + initObjLinker RetainCAFs + -- load plugins + forM ps $ \(ExternalPluginSpec path unit mod_name opts) -> do + loadExternalPluginLib path + -- lookup symbol + let ztmp = zEncodeString mod_name ++ "_plugin_closure" + symbol + | null unit = ztmp + | otherwise = zEncodeString unit ++ "_" ++ ztmp + plugin <- lookupSymbol symbol >>= \case + Nothing -> pprPanic "loadExternalPlugins" + (vcat [ text "Symbol not found" + , text " Library path: " <> text path + , text " Symbol : " <> text symbol + ]) + Just (Ptr addr) -> case addrToAny# addr of + (# a #) -> pure a + + pure $ ExternalPlugin (PluginWithArgs plugin opts) unit mod_name + +loadExternalPluginLib :: FilePath -> IO () +loadExternalPluginLib path = do + -- load library + loadDLL path >>= \case + Just errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Nothing -> do + -- resolve objects + resolveObjs >>= \case + True -> return () + False -> pprPanic "loadExternalPluginLib" (text "Unable to resolve objects for library: " <> text path) + +#endif diff --git a/compiler/GHC/Driver/Plugins/External.hs b/compiler/GHC/Driver/Plugins/External.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Plugins/External.hs @@ -0,0 +1,79 @@ +-- | External plugins +-- +-- GHC supports two kinds of "static" plugins: +-- 1. internal: setup with GHC-API +-- 2. external: setup as explained below and loaded from shared libraries +-- +-- The intended use case for external static plugins is with cross compilers: at +-- the time of writing, GHC is mono-target and a GHC cross-compiler (i.e. when +-- host /= target) can't build nor load plugins for the host using the +-- "non-static" plugin approach. Fixing this is tracked in #14335. If you're not +-- using a cross-compiler, you'd better use non-static plugins which are easier +-- to build and and safer to use (see below). +-- +-- External static plugins can be configured via the command-line with +-- the -fplugin-library flag. Syntax is: +-- +-- -fplugin-library=⟨file-path⟩;⟨unit-id⟩;⟨module⟩;⟨args⟩ +-- +-- Example: +-- -fplugin-library=path/to/plugin;package-123;Plugin.Module;["Argument","List"] +-- +-- Building the plugin library: +-- 1. link with the libraries used to build the compiler you target. If you +-- target a cross-compiler (stage2), you can't directly use it to build the +-- plugin library. Use the stage1 compiler instead. +-- +-- 2. if you use cabal to build the library, its unit-id will be set by cabal +-- and will contain a hash (e.g. "my-plugin-unit-1345656546ABCDEF"). To force +-- the unit id, use GHC's `-this-unit-id` command line flag: +-- e.g. -this-unit-id my-plugin-unit +-- You can set this in the .cabal file of your library with the following +-- stanza: `ghc-options: -this-unit-id my-plugin-unit` +-- +-- 3. To make your plugin easier to distribute, you may want to link it +-- statically with all its dependencies. You would need to use `-shared` +-- without `-dynamic` when building your library. +-- +-- However, all the static dependencies have to be built with `-fPIC` and it's +-- not done by default. See +-- https://www.hobson.space/posts/haskell-foreign-library/ for a way to modify +-- the compiler to do it. +-- +-- In any case, don't link your plugin library statically with the RTS (e.g. +-- use `-fno-link-rts`) as there are some global variables in the RTS that must +-- be shared between the plugin and the compiler. +-- +-- With external static plugins we don't check the type of the `plugin` closure +-- we look up. If it's not a valid `Plugin` value, it will probably crash badly. +-- + +module GHC.Driver.Plugins.External + ( ExternalPluginSpec (..) + , parseExternalPluginSpec + ) +where + +import GHC.Prelude +import Text.Read + +-- | External plugin spec +data ExternalPluginSpec = ExternalPluginSpec + { esp_lib :: !FilePath + , esp_unit_id :: !String + , esp_module :: !String + , esp_args :: ![String] + } + +-- | Parser external static plugin specification from command-line flag +parseExternalPluginSpec :: String -> Maybe ExternalPluginSpec +parseExternalPluginSpec optflag = + case break (== ';') optflag of + (libPath, _:rest) -> case break (== ';') rest of + (libName, _:pack) -> case break (== ';') pack of + (modName, _:args) -> case readMaybe args of + Just as -> Just (ExternalPluginSpec libPath libName modName as) + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + _ -> Nothing diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -26,14 +26,14 @@ showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) --- | Allows caller to specify the PrintUnqualified to use -showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String -showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc' +-- | Allows caller to specify the NamePprCtx to use +showSDocForUser :: DynFlags -> UnitState -> NamePprCtx -> SDoc -> String +showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDocContext dflags sty) doc' where - sty = mkUserStyle unqual AllTheWay + sty = mkUserStyle name_ppr_ctx AllTheWay doc' = pprWithUnitState unit_state doc -printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () -printForUser dflags handle unqual depth doc +printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser dflags handle name_ppr_ctx depth doc = printSDocLn ctx (PageMode False) handle doc - where ctx = initSDocContext dflags (mkUserStyle unqual depth) + where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -O0 #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} @@ -41,6 +42,7 @@ DynamicTooState(..), dynamicTooState, setDynamicNow, sccProfilingEnabled, needSourceNotes, + OnOff(..), DynFlags(..), outputFile, objectSuf, ways, FlagSpec(..), @@ -72,9 +74,6 @@ safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, - -- ** LLVM Targets - LlvmTarget(..), LlvmConfig(..), - -- ** System tool settings and locations Settings(..), sProgramName, @@ -85,7 +84,6 @@ sTopDir, sGlobalPackageDatabasePath, sLdSupportsCompactUnwind, - sLdSupportsBuildId, sLdSupportsFilelist, sLdIsGnuLd, sGccSupportsNoPie, @@ -100,7 +98,6 @@ sPgm_dll, sPgm_T, sPgm_windres, - sPgm_libtool, sPgm_ar, sPgm_ranlib, sPgm_lo, @@ -134,7 +131,7 @@ versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T, - pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool, + pgm_windres, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, opt_P_signature, @@ -218,6 +215,7 @@ -- * SDoc initSDocContext, initDefaultSDocContext, + initPromotionTickContext, ) where import GHC.Prelude @@ -234,6 +232,7 @@ import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Backend +import GHC.Driver.Plugins.External import GHC.Settings.Config import GHC.Utils.CliOption import GHC.Core.Unfold @@ -251,6 +250,7 @@ import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) +import GHC.Types.ProfAuto import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString import GHC.Utils.TmpFs @@ -419,7 +419,7 @@ Build systems with a remote cache like Bazel or Buck (or Shake, see #16956) store the build artifacts produced by a build BA for reuse in subsequent builds. - Embedding source paths in interface fingerprints will thwart these attemps and + Embedding source paths in interface fingerprints will thwart these attempts and lead to unnecessary recompilations when the source paths in BA differ from the source paths in subsequent builds. -} @@ -454,9 +454,6 @@ rawSettings :: [(String, String)], tmpDir :: TempDir, - llvmConfig :: LlvmConfig, - -- ^ N.B. It's important that this field is lazy since we load the LLVM - -- configuration lazily. See Note [LLVM configuration] in "GHC.SysTools". llvmOptLevel :: Int, -- ^ LLVM optimisation level verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] debugLevel :: Int, -- ^ How much debug information to produce @@ -597,6 +594,9 @@ -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* -- order that they're specified on the command line. + externalPluginSpecs :: [ExternalPluginSpec], + -- ^ External plugins loaded from shared libraries + -- For ghc -M depMakefile :: FilePath, depIncludePkgDeps :: Bool, @@ -740,6 +740,15 @@ cfgWeights :: Weights } +{- Note [RHS Floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to + 'doFloatFromRhs'; with this we can control floating out with GHC flags. + + This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and + allows for experimentation. +-} + class HasDynFlags m where getDynFlags :: m DynFlags @@ -767,27 +776,8 @@ class ContainsDynFlags t where extractDynFlags :: t -> DynFlags -data ProfAuto - = NoProfAuto -- ^ no SCC annotations added - | ProfAutoAll -- ^ top-level and nested functions are annotated - | ProfAutoTop -- ^ top-level functions annotated only - | ProfAutoExports -- ^ exported functions annotated only - | ProfAutoCalls -- ^ annotate call-sites - deriving (Eq,Enum) - -data LlvmTarget = LlvmTarget - { lDataLayout :: String - , lCPU :: String - , lAttributes :: [String] - } - --- | See Note [LLVM configuration] in "GHC.SysTools". -data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] - , llvmPasses :: [(Int, String)] - } - ----------------------------------------------------------------------------- --- Accessessors from 'DynFlags' +-- Accessors from 'DynFlags' -- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the -- vast majority of code. But GHCi questionably uses this to produce a default @@ -840,16 +830,10 @@ pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags pgm_windres :: DynFlags -> String pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags -pgm_libtool :: DynFlags -> String -pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags pgm_lcc :: DynFlags -> (String,[Option]) pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags pgm_ar :: DynFlags -> String pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags -pgm_otool :: DynFlags -> String -pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags -pgm_install_name_tool :: DynFlags -> String -pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags pgm_ranlib :: DynFlags -> String pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags pgm_lo :: DynFlags -> (String,[Option]) @@ -1121,8 +1105,8 @@ -- | The normal 'DynFlags'. Note that they are not suitable for use in this form -- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> LlvmConfig -> DynFlags -defaultDynFlags mySettings llvmConfig = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = -- See Note [Updating flag description in the User's Guide] DynFlags { ghcMode = CompManager, @@ -1195,6 +1179,8 @@ pluginModNameOpts = [], frontendPluginOpts = [], + externalPluginSpecs = [], + outputFile_ = Nothing, dynOutputFile_ = Nothing, outputHi = Nothing, @@ -1231,8 +1217,6 @@ tmpDir = panic "defaultDynFlags: uninitialized tmpDir", - -- See Note [LLVM configuration]. - llvmConfig = llvmConfig, llvmOptLevel = 0, -- ghc -M values @@ -1451,36 +1435,7 @@ -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool -dopt f dflags = (f `EnumSet.member` dumpFlags dflags) - || (verbosity dflags >= 4 && enableIfVerbose f) - where enableIfVerbose Opt_D_dump_tc_trace = False - enableIfVerbose Opt_D_dump_rn_trace = False - enableIfVerbose Opt_D_dump_cs_trace = False - enableIfVerbose Opt_D_dump_if_trace = False - enableIfVerbose Opt_D_dump_tc = False - enableIfVerbose Opt_D_dump_rn = False - enableIfVerbose Opt_D_dump_rn_stats = False - enableIfVerbose Opt_D_dump_hi_diffs = False - enableIfVerbose Opt_D_verbose_core2core = False - enableIfVerbose Opt_D_verbose_stg2stg = False - enableIfVerbose Opt_D_dump_splices = False - enableIfVerbose Opt_D_th_dec_file = False - enableIfVerbose Opt_D_dump_rule_firings = False - enableIfVerbose Opt_D_dump_rule_rewrites = False - enableIfVerbose Opt_D_dump_simpl_trace = False - enableIfVerbose Opt_D_dump_rtti = False - enableIfVerbose Opt_D_dump_inlinings = False - enableIfVerbose Opt_D_dump_verbose_inlinings = False - enableIfVerbose Opt_D_dump_core_stats = False - enableIfVerbose Opt_D_dump_asm_stats = False - enableIfVerbose Opt_D_dump_types = False - enableIfVerbose Opt_D_dump_simpl_iterations = False - enableIfVerbose Opt_D_dump_ticked = False - enableIfVerbose Opt_D_dump_view_pattern_commoning = False - enableIfVerbose Opt_D_dump_mod_cycles = False - enableIfVerbose Opt_D_dump_mod_map = False - enableIfVerbose Opt_D_dump_ec_trace = False - enableIfVerbose _ = True +dopt = getDumpFlagFrom verbosity dumpFlags -- | Set a 'DumpFlag' dopt_set :: DynFlags -> DumpFlag -> DynFlags @@ -1765,6 +1720,11 @@ [] -> "" -- should probably signal an error (_:plug_opt) -> plug_opt -- ignore the ':' from break +addExternalPlugin :: String -> DynFlags -> DynFlags +addExternalPlugin optflag d = case parseExternalPluginSpec optflag of + Just r -> d { externalPluginSpecs = r : externalPluginSpecs d } + Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag + addFrontendPluginOption :: String -> DynFlags -> DynFlags addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } @@ -1882,6 +1842,7 @@ parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) instance Monad (CmdLineP s) where CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) @@ -1891,9 +1852,6 @@ pure x = CmdLineP (pure x) (<*>) = ap -instance Functor (CmdLineP s) where - fmap f (CmdLineP k) = CmdLineP (fmap f k) - getCmdLineState :: CmdLineP s s getCmdLineState = CmdLineP State.get @@ -1995,8 +1953,9 @@ "-fpackage-trust ignored;" ++ " must be specified with a Safe Haskell flag"] - -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference] - safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main + -- Force this to avoid retaining reference to old DynFlags value + !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer {- ********************************************************************** @@ -2194,8 +2153,6 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } , make_ord_flag defFlag "pgmwindres" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } - , make_ord_flag defFlag "pgmlibtool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } , make_ord_flag defFlag "pgmar" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } , make_ord_flag defFlag "pgmotool" @@ -2236,14 +2193,10 @@ , make_ord_flag defGhcFlag "split-objs" (NoArg $ addWarn "ignoring -split-objs") + -- N.B. We may someday deprecate this in favor of -fsplit-sections, + -- which has the benefit of also having a negating -fno-split-sections. , make_ord_flag defGhcFlag "split-sections" - (noArgM (\dflags -> do - if platformHasSubsectionsViaSymbols (targetPlatform dflags) - then do addWarn $ - "-split-sections is not useful on this platform " ++ - "since it always uses subsections via symbols. Ignoring." - return dflags - else return (gopt_set dflags Opt_SplitSections))) + (NoArg $ setGeneralFlag Opt_SplitSections) -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) @@ -2317,9 +2270,9 @@ , make_ord_flag defGhcFlag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) -- This only makes sense as plural , make_ord_flag defGhcFlag "keep-tmp-files" (NoArg (setGeneralFlag Opt_KeepTmpFiles)) @@ -2423,7 +2376,7 @@ , make_ord_flag defFlag "fdiagnostics-color=never" (NoArg (upd (\d -> d { useColor = Never }))) - -- Suppress all that is suppressable in core dumps. + -- Suppress all that is suppressible in core dumps. -- Except for uniques, as some simplifier phases introduce new variables that -- have otherwise identical names. , make_ord_flag defGhcFlag "dsuppress-all" @@ -2478,12 +2431,16 @@ (setDumpFlag Opt_D_dump_cmm_cps) , make_ord_flag defGhcFlag "ddump-cmm-opt" (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer" + (setDumpFlag Opt_D_dump_cmm_thread_sanitizer) , make_ord_flag defGhcFlag "ddump-cfg-weights" (setDumpFlag Opt_D_dump_cfg_weights) , make_ord_flag defGhcFlag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , make_ord_flag defGhcFlag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-js" + (setDumpFlag Opt_D_dump_js) , make_ord_flag defGhcFlag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) , make_ord_flag defGhcFlag "ddump-asm-liveness" @@ -2747,6 +2704,8 @@ , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin) + ------ Optimisation flags ------------------------------------------ , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) "Use -O0 instead" @@ -2928,24 +2887,25 @@ (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend NCG)) + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) , make_ord_flag defGhcFlag "fvia-c" (NoArg (deprecate $ "The -fvia-c flag does nothing; " ++ "it will be removed in a future GHC release")) , make_ord_flag defGhcFlag "fvia-C" (NoArg (deprecate $ "The -fvia-C flag does nothing; " ++ "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend LLVM)) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setBackend NoBackend)) + d { ghcLink=NoLink }) >> setBackend noBackend)) , make_ord_flag defFlag "fbyte-code" (noArgM $ \dflags -> do - setBackend Interpreter - pure $ gopt_set dflags Opt_ByteCode) - , make_ord_flag defFlag "fobject-code" $ NoArg $ do - dflags <- liftEwM getCmdLineState + setBackend interpreterBackend + pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode)) + , make_ord_flag defFlag "fobject-code" $ noArgM $ \dflags -> do setBackend $ platformDefaultBackend (targetPlatform dflags) + dflags' <- liftEwM getCmdLineState + pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode , make_dep_flag defFlag "fglasgow-exts" (NoArg enableGlasgowExts) "Use individual extensions instead" @@ -3218,6 +3178,17 @@ flag | turn_on = lang | otherwise = "No" ++ lang +deprecatedForExtensions :: [String] -> TurnOnFlag -> String +deprecatedForExtensions [] _ = panic "new extension has not been specified" +deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on +deprecatedForExtensions langExts turn_on + = "use " ++ xExt flags ++ " instead" + where + flags | turn_on = langExts + | otherwise = ("No" ++) <$> langExts + + xExt fls = intercalate " and " $ (\flag -> "-X" ++ flag) <$> fls + useInstead :: String -> String -> TurnOnFlag -> String useInstead prefix flag turn_on = "Use " ++ prefix ++ no ++ flag ++ " instead" @@ -3417,6 +3388,9 @@ flagSpec "defer-typed-holes" Opt_DeferTypedHoles, flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + -- With-ways needs to be reversible hence why its made via flagSpec unlike + -- other debugging flags. + flagSpec "dump-with-ways" Opt_DumpWithWays, flagSpec "dicts-cheap" Opt_DictsCheap, flagSpec "dicts-strict" Opt_DictsStrict, depFlagSpec "dmd-tx-dict-sel" @@ -3441,6 +3415,8 @@ flagSpec "full-laziness" Opt_FullLaziness, depFlagSpec' "fun-to-thunk" Opt_FunToThunk (useInstead "-f" "full-laziness"), + flagSpec "local-float-out" Opt_LocalFloatOut, + flagSpec "local-float-out-top-level" Opt_LocalFloatOutTopLevel, flagSpec "gen-manifest" Opt_GenManifest, flagSpec "ghci-history" Opt_GhciHistory, flagSpec "ghci-leak-check" Opt_GhciLeakCheck, @@ -3480,6 +3456,7 @@ flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-redundant-promotion-ticks" Opt_PrintRedundantPromotionTicks, flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, @@ -3505,12 +3482,13 @@ flagSpec "strictness" Opt_Strictness, flagSpec "use-rpaths" Opt_RPath, flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-if-simplified-core" Opt_WriteIfSimplifiedCore, flagSpec "write-ide-info" Opt_WriteHie, flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, flagSpec "version-macros" Opt_VersionMacros, flagSpec "worker-wrapper" Opt_WorkerWrapper, - flagSpec "worker-wrapper-cbv" Opt_WorkerWrapperUnlift, + flagSpec "worker-wrapper-cbv" Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments] flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases, flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, @@ -3525,12 +3503,16 @@ flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, flagSpec "keep-cafs" Opt_KeepCAFs, flagSpec "link-rts" Opt_LinkRts, + flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, + flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, flagSpec' "compact-unwind" Opt_CompactUnwind (\turn_on -> updM (\dflags -> do unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") - return dflags)) - + return dflags)), + flagSpec "show-error-context" Opt_ShowErrorContext, + flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, + flagSpec "split-sections" Opt_SplitSections ] ++ fHoleFlags @@ -3785,7 +3767,9 @@ flagSpec "TransformListComp" LangExt.TransformListComp, flagSpec "TupleSections" LangExt.TupleSections, flagSpec "TypeApplications" LangExt.TypeApplications, - flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeData" LangExt.TypeData, + depFlagSpec' "TypeInType" LangExt.TypeInType + (deprecatedForExtensions ["DataKinds", "PolyKinds"]), flagSpec "TypeFamilies" LangExt.TypeFamilies, flagSpec "TypeOperators" LangExt.TypeOperators, flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, @@ -3820,17 +3804,24 @@ Opt_SimplPreInlining, Opt_VersionMacros, Opt_RPath, + Opt_DumpWithWays, Opt_CompactUnwind, + Opt_ShowErrorContext, Opt_SuppressStgReps ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options + -- Default floating flags (see Note [RHS Floating]) + ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ] + + ++ default_PIC platform ++ validHoleFitDefaults + where platform = sTargetPlatform settings -- | These are the default settings for the display and sorting of valid hole @@ -3889,6 +3880,8 @@ ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface) + ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore) ] ++ validHoleFitsImpliedGFlags -- General flags that are switched on/off when other general flags are switched @@ -4449,7 +4442,7 @@ -- code are allowed (requests for other target types are ignored). setBackend :: Backend -> DynP () setBackend l = upd $ \ dfs -> - if ghcLink dfs /= LinkBinary || backendProducesObject l + if ghcLink dfs /= LinkBinary || backendWritesFiles l then dfs{ backend = l } else dfs @@ -4461,7 +4454,7 @@ setObjBackend l = updM set where set dflags - | backendProducesObject (backend dflags) + | backendWritesFiles (backend dflags) = return $ dflags { backend = l } | otherwise = return dflags @@ -4476,12 +4469,11 @@ setMainIs :: String -> DynP () setMainIs arg - | not (null main_fn) && isLower (head main_fn) - -- The arg looked like "Foo.Bar.baz" + | x:_ <- main_fn, isLower x -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d { mainFunIs = Just main_fn, mainModuleNameIs = mkModuleName main_mod } - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | x:_ <- arg, isUpper x -- The arg looked like "Foo" or "Foo.Bar" = upd $ \d -> d { mainModuleNameIs = mkModuleName arg } | otherwise -- The arg looked like "baz" @@ -4806,32 +4798,42 @@ warn = "-dynamic-too is ignored when using -dynamic" in loop dflags' warn + | gopt Opt_SplitSections dflags + , platformHasSubsectionsViaSymbols (targetPlatform dflags) + = let dflags' = gopt_unset dflags Opt_SplitSections + warn = "-fsplit-sections is not useful on this platform " ++ + "since it uses subsections-via-symbols. Ignoring." + in loop dflags' warn + -- Via-C backend only supports unregisterised ABI. Switch to a backend -- supporting it if possible. - | backend dflags == ViaC && + | backendUnregisterisedAbiOnly (backend dflags) && not (platformUnregisterised (targetPlatform dflags)) - = case platformDefaultBackend (targetPlatform dflags) of - NCG -> let dflags' = dflags { backend = NCG } - warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C" - in loop dflags' warn - LLVM -> let dflags' = dflags { backend = LLVM } - warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C" - in loop dflags' warn - _ -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it." + = let b = platformDefaultBackend (targetPlatform dflags) + in if backendSwappableWithViaC b then + let dflags' = dflags { backend = b } + warn = "Target platform doesn't use unregisterised ABI, so using " ++ + backendDescription b ++ " rather than " ++ + backendDescription (backend dflags) + in loop dflags' warn + else + pgmError (backendDescription (backend dflags) ++ + " supports only unregisterised ABI but target platform doesn't use it.") - | gopt Opt_Hpc dflags && backend dflags == Interpreter + | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ + ". Ignoring -fhpc." in loop dflags' warn - | backend dflags `elem` [NCG, LLVM] && + | backendSwappableWithViaC (backend dflags) && platformUnregisterised (targetPlatform dflags) - = loop (dflags { backend = ViaC }) + = loop (dflags { backend = viaCBackend }) "Target platform uses unregisterised ABI, so compiling via C" - | backend dflags == NCG && + | backendNeedsPlatformNcgSupport (backend dflags) && not (platformNcgSupported $ targetPlatform dflags) - = let dflags' = dflags { backend = LLVM } + = let dflags' = dflags { backend = llvmBackend } warn = "Native code generator doesn't support target platform, so using LLVM" in loop dflags' warn @@ -4844,15 +4846,17 @@ = loop (gopt_set dflags Opt_PIC) "Enabling -fPIC as it is always on for this platform" - | backend dflags == Interpreter + | backendForcesOptimization0 (backend dflags) , let (dflags', changed) = updOptLevelChanged 0 dflags , changed - = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored." + = loop dflags' ("Optimization flags are incompatible with the " ++ + backendDescription (backend dflags) ++ + "; optimization flags ignored.") | LinkInMemory <- ghcLink dflags , not (gopt Opt_ExternalInterpreter dflags) , hostIsProfiled - , backendProducesObject (backend dflags) + , backendWritesFiles (backend dflags) , ways dflags `hasNotWay` WayProf = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" @@ -4946,6 +4950,7 @@ | Clang | AppleClang | AppleClang51 + | Emscripten | UnknownCC deriving Eq @@ -5038,8 +5043,8 @@ , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags - , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } @@ -5047,6 +5052,13 @@ -- | Initialize the pretty-printing options using the default user style initDefaultSDocContext :: DynFlags -> SDocContext initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle + +initPromotionTickContext :: DynFlags -> PromotionTickContext +initPromotionTickContext dflags = + PromTickCtx { + ptcListTuplePuns = True, + ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags + } outputFile :: DynFlags -> Maybe String outputFile dflags diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -10,6 +10,7 @@ therefore, is almost nothing but re-exporting. -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} @@ -35,7 +36,7 @@ Fixity, HsModule(..), AnnsModule(..), - HsParsedModule(..) + HsParsedModule(..), XModulePs(..) ) where -- friends: @@ -59,53 +60,18 @@ import GHC.Utils.Outputable import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc -import GHC.Unit.Module ( ModuleName ) import GHC.Unit.Module.Warnings ( WarningTxt ) -- libraries: import Data.Data hiding ( Fixity ) --- | Haskell Module --- --- All we actually declare here is the top-level structure for a module. -data HsModule - = -- | 'GHC.Parser.Annotation.AnnKeywordId's - -- - -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere' - -- - -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around - -- hsmodImports,hsmodDecls if this style is used. - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - HsModule { +-- | Haskell Module extension point: GHC specific +data XModulePs + = XModulePs { hsmodAnn :: EpAnn AnnsModule, - hsmodLayout :: LayoutInfo, + hsmodLayout :: LayoutInfo GhcPs, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. - hsmodName :: Maybe (LocatedA ModuleName), - -- ^ @Nothing@: \"module X where\" is omitted (in which case the next - -- field is Nothing too) - hsmodExports :: Maybe (LocatedL [LIE GhcPs]), - -- ^ Export list - -- - -- - @Nothing@: export list omitted, so export everything - -- - -- - @Just []@: export /nothing/ - -- - -- - @Just [...]@: as you would expect... - -- - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' - -- ,'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - hsmodImports :: [LImportDecl GhcPs], - -- ^ We snaffle interesting stuff out of the imported interfaces early - -- on, adding that info to TyDecls/etc; so this list is often empty, - -- downstream. - hsmodDecls :: [LHsDecl GhcPs], - -- ^ Type, class, value, and interface signature decls hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), -- ^ reason\/explanation for warning/deprecation of this module -- @@ -122,29 +88,44 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation } + deriving Data -deriving instance Data HsModule +type instance XCModule GhcPs = XModulePs +type instance XCModule GhcRn = DataConCantHappen +type instance XCModule GhcTc = DataConCantHappen +type instance XXModule p = DataConCantHappen +type instance Anno ModuleName = SrcSpanAnnA + +deriving instance Data (HsModule GhcPs) + data AnnsModule = AnnsModule { am_main :: [AddEpAnn], am_decls :: AnnList } deriving (Data, Eq) -instance Outputable HsModule where - - ppr (HsModule _ _ Nothing _ imports decls _ mbDoc) +instance Outputable (HsModule GhcPs) where + ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc } + , hsmodName = Nothing + , hsmodImports = imports + , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc) + ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec + , hsmodHaddockModHeader = mbDoc } + , hsmodName = (Just name) + , hsmodExports = exports + , hsmodImports = imports + , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ vcat [ case exports of Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), + nest 8 (pprWithCommas ppr (unLoc es)), nest 4 (text ") where") ], pp_nonnull imports, @@ -162,7 +143,7 @@ pp_nonnull xs = vcat (map ppr xs) data HsParsedModule = HsParsedModule { - hpm_module :: Located HsModule, + hpm_module :: Located (HsModule GhcPs), hpm_src_files :: [FilePath] -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# ' pragmas, which the C preprocessor diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -28,12 +28,13 @@ import GHC.Prelude +import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Binds import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) -import Language.Haskell.Syntax.Extension +import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Hs.Type @@ -66,7 +67,7 @@ Global bindings (where clauses) -} --- the ...LR datatypes are parametrized by two id types, +-- the ...LR datatypes are parameterized by two id types, -- one for the left and one for the right. type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList @@ -95,9 +96,10 @@ -- extension field contains the locally-bound free variables of this -- defn. See Note [Bind free vars] -type instance XFunBind (GhcPass pL) GhcTc = HsWrapper --- ^ After the type-checker, the FunBind extension field contains a --- coercion from the type of the MatchGroup to the type of the Id. +type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish]) +-- ^ After the type-checker, the FunBind extension field contains +-- the ticks to put on the rhs, if any, and a coercion from the +-- type of the MatchGroup to the type of the Id. -- Example: -- -- @ @@ -113,7 +115,10 @@ type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] -type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs +type instance XPatBind GhcTc (GhcPass pR) = + ( Type -- Type of the GRHSs + , ( [CoreTickish] -- Ticks to put on the rhs, if any + , [[CoreTickish]] ) ) -- and ticks to put on the bound variables. type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField @@ -512,14 +517,27 @@ = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_matches = matches, - fun_tick = ticks, - fun_ext = wrap }) - = pprTicks empty (if null ticks then empty - else text "-- ticks = " <> ppr ticks) + fun_ext = ext }) + = pprTicks empty ticksDoc $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ whenPprDebug (pprIfTc @idR $ ppr wrap) + $$ whenPprDebug (pprIfTc @idR $ wrapDoc) + where + ticksDoc :: SDoc + ticksDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (_, ticks) <- ext -> + if null ticks + then empty + else text "-- ticks = " <> ppr ticks + wrapDoc :: SDoc + wrapDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (wrap, _) <- ext -> ppr wrap + ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of #if __GLASGOW_HASKELL__ <= 900 @@ -600,6 +618,10 @@ then pp_when_debug else pp_no_debug +instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v + + {- ************************************************************************ * * @@ -651,20 +673,28 @@ type instance XTypeSig (GhcPass p) = EpAnn AnnSig type instance XPatSynSig (GhcPass p) = EpAnn AnnSig type instance XClassOpSig (GhcPass p) = EpAnn AnnSig -type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn] type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn] type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSpecInstSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] - -type instance XXSig (GhcPass p) = DataConCantHappen +type instance XSpecInstSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) +type instance XMinimalSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) +type instance XSCCFunSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) +type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) + -- SourceText: Note [Pragma source text] in GHC.Types.SourceText +type instance XXSig GhcPs = DataConCantHappen +type instance XXSig GhcRn = IdSig +type instance XXSig GhcTc = IdSig type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +-- | A type signature in generated code, notably the code +-- generated for record selectors. We simply record the desired Id +-- itself, replete with its name, type and IdDetails. Otherwise it's +-- just like a type signature: there should be an accompanying binding +newtype IdSig = IdSig { unIdSig :: Id } + deriving Data + data AnnSig = AnnSig { asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option @@ -714,7 +744,6 @@ ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var) @@ -724,22 +753,25 @@ NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl) _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE" ppr_sig (InlineSig _ var inl) - = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE" (pprInline inl - <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig _ src ty) + = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}" + where + ppr_pfx = case inlinePragmaSource inl of + SourceText src -> text src + NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) +ppr_sig (SpecInstSig (_, src) ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig _ src bf) +ppr_sig (MinimalSig (_, src) bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig _ src fn mlabel) +ppr_sig (SCCFunSig (_, src) fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) where ppr_fn = case ghcPass @p of GhcPs -> ppr fn GhcRn -> ppr fn GhcTc -> ppr fn -ppr_sig (CompleteMatchSig _ src cs mty) +ppr_sig (CompleteMatchSig (_, src) cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr_n (unLoc cs)))) <+> opt_sig) @@ -749,7 +781,41 @@ GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n +ppr_sig (XSig x) = case ghcPass @p of + GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) +hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" +-- Using the 'inlinePragmaName' function ensures that the pragma name for any +-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted +-- from the InlineSpec field of the pragma. +hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig _) = case ghcPass @p of + GhcRn -> text "id signature" + GhcTc -> text "id signature" + +-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src +-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE +-- instance pragma of the form: "SourceText {-# SPECIALIZE" +-- +-- Extraction ensures that all variants of the pragma name (with a 'Z' or an +-- 'S') are output exactly as used in the pragma. +extractSpecPragName :: SourceText -> String +extractSpecPragName srcTxt = case (words $ show srcTxt) of + (_:_:pragName:_) -> filter (/= '\"') pragName + _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) + instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] @@ -782,7 +848,7 @@ instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) - = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl + = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl pprMinimalSig :: (OutputableBndr name) => LBooleanFormula (GenLocated l name) -> SDoc diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -16,9 +16,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, @@ -27,7 +24,7 @@ -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData, newOrDataToFlavour, anyLConIsGadt, StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, -- ** Class or type declarations @@ -43,7 +40,8 @@ tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, - FunDep(..), + FunDep(..), ppDataDefnHeader, + pp_vanilla_decl_head, -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), @@ -69,7 +67,7 @@ -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice - SpliceExplicitFlag(..), + SpliceDecoration(..), SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), @@ -104,7 +102,7 @@ import Language.Haskell.Syntax.Decls -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl ) +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) -- Because Expr imports Decls via HsBracket import GHC.Hs.Binds @@ -120,16 +118,19 @@ import GHC.Types.Fixity -- others: +import GHC.Utils.Misc (count) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type +import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall import GHC.Data.Bag import GHC.Data.Maybe import Data.Data (Data) +import Data.Foldable (toList) {- ************************************************************************ @@ -187,6 +188,10 @@ -> (bs, ss, ts, tfis, dfis, L l d : docs) _ -> pprPanic "partitionBindsAndSigs" (ppr decl) +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable (DocDecl name) where + ppr _ = text "" + type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = DataConCantHappen @@ -313,8 +318,14 @@ instance OutputableBndrId p => Outputable (SpliceDecl (GhcPass p)) where - ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e + ppr (SpliceDecl _ (L _ e) BareSplice) = pprUntypedSplice False Nothing e +instance Outputable SpliceDecoration where + ppr x = text $ show x + + + {- ************************************************************************ * * @@ -333,7 +344,14 @@ type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + -- See Note [CUSKs: complete user-supplied kind signatures] + , tcdFVs :: NameSet } + deriving Data + +type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) + -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs @@ -343,6 +361,17 @@ type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen +------------- Pretty printing FamilyDecls ----------- + +pprFlavour :: FamilyInfo pass -> SDoc +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" + +instance Outputable (FamilyInfo pass) where + ppr info = pprFlavour info <+> text "family" + + -- Dealing with names tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN @@ -361,6 +390,21 @@ tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True + isNewTy _ = False + -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it -- needs to be polymorphic in the pass tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN @@ -441,10 +485,11 @@ = hsep [pprLHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) - | fixity == Infix && length varsr > 1 + | fixity == Infix, varr:varsr'@(_:_) <- varsr + -- If varsr has at least 2 elements, parenthesize. = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) - , (ppr.unLoc) (head varsr), char ')' - , hsep (map (ppr.unLoc) (tail varsr))] + , (ppr.unLoc) varr, char ')' + , hsep (map (ppr.unLoc) varsr')] | fixity == Infix = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr.unLoc) varsr)] @@ -457,8 +502,8 @@ pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) + = ppr (dataDefnConsNewOrData nd) instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep @@ -590,6 +635,15 @@ Just (L _ via@ViaStrategy{}) -> (empty, ppr via) _ -> (ppDerivStrategy dcs, empty) +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy {} = "stock" + go AnyclassStrategy {} = "anyclass" + go NewtypeStrategy {} = "newtype" + go ViaStrategy {} = "via" + type instance XDctSingle (GhcPass _) = NoExtField type instance XDctMulti (GhcPass _) = NoExtField type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen @@ -612,9 +666,10 @@ type instance XXConDecl (GhcPass _) = DataConCantHappen +-- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98 {con_name = name} = [name] -getConNames ConDeclGADT {con_names = names} = names +getConNames ConDeclGADT {con_names = names} = toList names -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. @@ -632,28 +687,41 @@ hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta +ppDataDefnHeader + :: (OutputableBndrId p) + => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +ppDataDefnHeader pp_hdr HsDataDefn + { dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls } + = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig + where + pp_type + | isTypeDataDefnCons condecls = text "type" + | otherwise = empty + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_data_defn :: (OutputableBndrId p) => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) +pp_data_defn pp_hdr defn@HsDataDefn + { dd_cons = condecls + , dd_derivs = derivings } | null condecls - = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig - <+> pp_derivings derivings + = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings | otherwise - = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) - 2 (pp_condecls condecls $$ pp_derivings derivings) + = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings) where - pp_ct = case mb_ct of - Nothing -> empty - Just ct -> ppr ct - pp_sig = case mb_sig of - Nothing -> empty - Just kind -> dcolon <+> ppr kind pp_derivings ds = vcat (map ppr ds) instance OutputableBndrId p @@ -667,15 +735,10 @@ pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs - | gadt_syntax -- In GADT syntax + | anyLConIsGadt cs -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) | otherwise -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl @@ -703,7 +766,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) - = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon + = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where @@ -797,9 +860,9 @@ -- pp_data_defn pretty-prints the kind sig. See #14817. pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = - (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})}) - = ppr nd +pprDataFamInstFlavour DataFamInstDecl + { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}} + = ppr (dataDefnConsNewOrData cons) pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) @@ -870,6 +933,23 @@ do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour + +instance Outputable NewOrData where + ppr NewType = text "newtype" + ppr DataType = text "data" + +-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@. +anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool +anyLConIsGadt xs = case toList xs of + L _ ConDeclGADT {} : _ -> True + _ -> False +{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-} +{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-} + {- ************************************************************************ * * @@ -986,6 +1066,14 @@ type instance XXForeignDecl (GhcPass _) = DataConCantHappen +type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity +type instance XXForeignImport (GhcPass _) = DataConCantHappen + +type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity +type instance XXForeignExport (GhcPass _) = DataConCantHappen + +-- pretty printing of foreign declarations + instance OutputableBndrId p => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) @@ -995,6 +1083,40 @@ hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) +instance OutputableBndrId p + => Outputable (ForeignImport (GhcPass p)) where + ppr (CImport (L _ srcText) cconv safety mHeader spec) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header _ header) -> ftext header + + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" + +instance OutputableBndrId p + => Outputable (ForeignExport (GhcPass p)) where + ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + {- ************************************************************************ * * @@ -1003,19 +1125,20 @@ ************************************************************************ -} -type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn] -type instance XCRuleDecls GhcRn = NoExtField -type instance XCRuleDecls GhcTc = NoExtField +type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XCRuleDecls GhcRn = SourceText +type instance XCRuleDecls GhcTc = SourceText type instance XXRuleDecls (GhcPass _) = DataConCantHappen -type instance XHsRule GhcPs = EpAnn HsRuleAnn -type instance XHsRule GhcRn = HsRuleRn -type instance XHsRule GhcTc = HsRuleRn +type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText) +type instance XHsRule GhcRn = (HsRuleRn, SourceText) +type instance XHsRule GhcTc = (HsRuleRn, SourceText) -type instance XXRuleDecl (GhcPass _) = DataConCantHappen +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data -type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns +type instance XXRuleDecl (GhcPass _) = DataConCantHappen data HsRuleAnn = HsRuleAnn @@ -1036,19 +1159,24 @@ type instance XXRuleBndr (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where - ppr (HsRules { rds_src = st + ppr (HsRules { rds_ext = ext , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + where st = case ghcPass @p of + GhcPs | (_, st) <- ext -> st + GhcRn -> ext + GhcTc -> ext instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where - ppr (HsRule { rd_name = name + ppr (HsRule { rd_ext = ext + , rd_name = name , rd_act = act , rd_tyvs = tys , rd_tmvs = tms , rd_lhs = lhs , rd_rhs = rhs }) - = sep [pprFullRuleName name <+> ppr act, + = sep [pprFullRuleName st name <+> ppr act, nest 4 (pp_forall_ty tys <+> pp_forall_tm tys <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] @@ -1057,11 +1185,19 @@ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot pp_forall_tm Nothing | null tms = empty pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot + st = case ghcPass @p of + GhcPs | (_, st) <- ext -> st + GhcRn | (_, st) <- ext -> st + GhcTc | (_, st) <- ext -> st instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr _ name) = ppr name ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) +pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc +pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) + + {- ************************************************************************ * * @@ -1070,9 +1206,9 @@ ************************************************************************ -} -type instance XWarnings GhcPs = EpAnn [AddEpAnn] -type instance XWarnings GhcRn = NoExtField -type instance XWarnings GhcTc = NoExtField +type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XWarnings GhcRn = SourceText +type instance XWarnings GhcTc = SourceText type instance XXWarnDecls (GhcPass _) = DataConCantHappen @@ -1082,9 +1218,13 @@ instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where - ppr (Warnings _ (SourceText src) decls) + ppr (Warnings ext decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + where src = case ghcPass @p of + GhcPs | (_, SourceText src) <- ext -> src + GhcRn | SourceText src <- ext -> src + GhcTc | SourceText src <- ext -> src + _ -> panic "WarnDecls" instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where @@ -1100,11 +1240,11 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma +type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where - ppr (HsAnnotation _ _ provenance expr) + ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc @@ -1185,3 +1325,6 @@ type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (Maybe Role) = SrcAnn NoEpAnns +type instance Anno CCallConv = SrcSpan +type instance Anno Safety = SrcSpan +type instance Anno CExportSpec = SrcSpan diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -36,10 +36,9 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set -import GHC.Unit.Module.Name import GHC.Driver.Flags -import Control.Applicative (liftA2) +import Control.DeepSeq import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -48,13 +47,15 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.LanguageExtensions.Type import qualified GHC.Utils.Outputable as O -import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Types.Unique.Map import Data.List (sortBy) import GHC.Hs.DocString +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name + -- | A docstring with the (probable) identifiers found in it. type HsDoc = WithHsDocIdentifiers HsDocString @@ -74,6 +75,8 @@ deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) +instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where + rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i -- | For compatibility with the existing @-ddump-parsed' output, we only show -- the docstring. @@ -85,9 +88,9 @@ instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh ids + put_ bh $ BinLocated <$> ids get bh = - liftA2 WithHsDocIdentifiers (get bh) (get bh) + liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to. @@ -118,19 +121,19 @@ -- | A simplified version of 'HsImpExp.IE'. data DocStructureItem - = DsiSectionHeading Int (HsDoc GhcRn) - | DsiDocChunk (HsDoc GhcRn) - | DsiNamedChunkRef String - | DsiExports Avails + = DsiSectionHeading !Int !(HsDoc GhcRn) + | DsiDocChunk !(HsDoc GhcRn) + | DsiNamedChunkRef !(String) + | DsiExports !Avails | DsiModExport - (NonEmpty ModuleName) -- ^ We might re-export avails from multiple + !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple -- modules with a single export declaration. E.g. -- when we have -- -- > module M (module X) where -- > import R0 as X -- > import R1 as X - Avails + !Avails instance Binary DocStructureItem where put_ bh = \case @@ -179,6 +182,15 @@ DsiModExport mod_names avails -> text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) +instance NFData DocStructureItem where + rnf = \case + DsiSectionHeading level doc -> rnf level `seq` rnf doc + DsiDocChunk doc -> rnf doc + DsiNamedChunkRef name -> rnf name + DsiExports avails -> rnf avails + DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails + + type DocStructure = [DocStructureItem] data Docs = Docs @@ -202,6 +214,12 @@ , docs_extensions :: EnumSet Extension -- ^ The full set of language extensions used in the module. } + +instance NFData Docs where + rnf (Docs mod_hdr decls args structure named_chunks haddock_opts language extentions) + = rnf mod_hdr `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks + `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions + `seq` () instance Binary Docs where put_ bh docs = do diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs --- a/compiler/GHC/Hs/DocString.hs +++ b/compiler/GHC/Hs/DocString.hs @@ -1,5 +1,7 @@ -- | An exactprintable structure for docstrings {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Hs.DocString ( LHsDocString @@ -27,6 +29,7 @@ import GHC.Utils.Encoding import GHC.Utils.Outputable as Outputable hiding ((<>)) import GHC.Types.SrcLoc +import Control.DeepSeq import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -59,6 +62,11 @@ instance Outputable HsDocString where ppr = text . renderHsDocString +instance NFData HsDocString where + rnf (MultiLineDocString a b) = rnf a `seq` rnf b + rnf (NestedDocString a b) = rnf a `seq` rnf b + rnf (GeneratedDocString a) = rnf a + -- | Annotate a pretty printed thing with its doc -- The docstring comes after if is 'HsDocStringPrevious' -- Otherwise it comes before. @@ -75,19 +83,19 @@ MultiLineDocString dec xs -> do putByte bh 0 put_ bh dec - put_ bh xs + put_ bh $ BinLocated <$> xs NestedDocString dec x -> do putByte bh 1 put_ bh dec - put_ bh x + put_ bh $ BinLocated x GeneratedDocString x -> do putByte bh 2 put_ bh x get bh = do tag <- getByte bh case tag of - 0 -> MultiLineDocString <$> get bh <*> get bh - 1 -> NestedDocString <$> get bh <*> get bh + 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) 2 -> GeneratedDocString <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t @@ -101,6 +109,12 @@ instance Outputable HsDocStringDecorator where ppr = text . printDecorator +instance NFData HsDocStringDecorator where + rnf HsDocStringNext = () + rnf HsDocStringPrevious = () + rnf (HsDocStringNamed x) = rnf x + rnf (HsDocStringGroup x) = rnf x + printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" printDecorator HsDocStringPrevious = "^" @@ -124,9 +138,10 @@ type LHsDocStringChunk = Located HsDocStringChunk --- | A continguous chunk of documentation +-- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString - deriving (Eq,Ord,Data, Show) + deriving stock (Eq,Ord,Data, Show) + deriving newtype (NFData) instance Binary HsDocStringChunk where put_ bh (HsDocStringChunk bs) = put_ bh bs @@ -135,9 +150,8 @@ instance Outputable HsDocStringChunk where ppr = text . unpackHDSC - mkHsDocStringChunk :: String -> HsDocStringChunk -mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s) +mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s) -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk @@ -192,6 +206,6 @@ unlines' = intercalate "\n" -- | Just get the docstring, without any decorators --- Seperates docstrings using "\n\n", which is how haddock likes to render them +-- Separates docstrings using "\n\n", which is how haddock likes to render them renderHsDocStrings :: [HsDocString] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -30,7 +30,6 @@ import GHC.Types.SrcLoc import GHC.Types.Var import GHC.Types.SourceText -import GHC.Unit.Module import GHC.Utils.Outputable import Data.Data hiding (Fixity) @@ -145,7 +144,7 @@ _ -> parens $ text "SourceText" <+> text "blanked" epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r epaAnchor (EpaDelta d cs) = case ba of NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" @@ -159,7 +158,7 @@ occName n = braces $ text "OccName:" - <+> text (occNameString n) + <+> ftext (occNameFS n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName:" <+> ppr m diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -14,7 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {- @@ -33,10 +32,11 @@ -- friends: import GHC.Prelude -import GHC.Hs.Decls +import GHC.Hs.Decls() -- import instances import GHC.Hs.Pat import GHC.Hs.Lit import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Binds @@ -44,8 +44,8 @@ -- others: import GHC.Tc.Types.Evidence -import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Fixity @@ -64,6 +64,9 @@ import GHC.Tc.Utils.TcType (TcType, TcTyVar) import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv) +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + -- libraries: import Data.Data hiding (Fixity(..)) import qualified Data.Data as Data (Fixity(..)) @@ -163,21 +166,6 @@ ppr NoSyntaxExprTc = text "" --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- For a data family, these are the type args of the - -- /representation/ type constructor - - , rupd_wrap :: HsWrapper -- See Note [Record Update HsWrapper] - } - -- | HsWrap appears only in typechecker output data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped @@ -186,80 +174,14 @@ -- --------------------------------------------------------------------- -{- -Note [The life cycle of a TH quotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When desugaring a bracket (aka quotation), we want to produce Core -code that, when run, will produce the TH syntax tree for the quotation. -To that end, we want to desugar /renamed/ but not /typechecked/ code; -the latter is cluttered with the typechecker's elaboration that should -not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must -have a (HsExpr GhcRn) for the quotation itself. - -As such, when typechecking both typed and untyped brackets, -we keep a /renamed/ bracket in the extension field. - -The HsBracketTc, the GhcTc ext field for both brackets, contains: - - The renamed quote :: HsQuote GhcRn -- for the desugarer - - [PendingTcSplice] - - The type of the quote - - Maybe QuoteWrapper - -Note that (HsBracketTc) stores the untyped (HsQuote GhcRn) for both typed and -untyped brackets. They are treated uniformly by the desugarer, and we can -easily construct untyped brackets from typed ones (with ExpBr). - -Typed quotes -~~~~~~~~~~~~ -Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is - HsTypedBracket (XTypedBracket p) (LHsExpr p) - - In pass p (XTypedBracket p) (LHsExpr p) - ------------------------------------------- - GhcPs Annotations only LHsExpr GhcPs - GhcRn Annotations only LHsExpr GhcRn - GhcTc HsBracketTc LHsExpr GhcTc: unused! - -Note that in the GhcTc tree, the second field (HsExpr GhcTc) -is entirely unused; the desugarer uses the (HsExpr GhcRn) from the -first field. - -Untyped quotes -~~~~~~~~~~~~~~ -Here is the life cycle of an /untyped/ quote, whose datacon is - HsUntypedBracket (XUntypedBracket p) (HsQuote p) - -Here HsQuote is a sum-type of expressions [| e |], patterns [| p |], -types [| t |] etc. - - In pass p (XUntypedBracket p) (HsQuote p) - ------------------------------------------------------- - GhcPs Annotations only HsQuote GhcPs - GhcRn Annotations, [PendingRnSplice] HsQuote GhcRn - GhcTc HsBracketTc HsQuote GhcTc: unused! - -The difficulty is: the typechecker does not typecheck the body of an -untyped quote, so how do we make a (HsQuote GhcTc) to put in the -second field? - -Answer: we use the extension constructor of HsQuote, XQuote, and make -all the other constructors into DataConCantHappen. That is, the only -non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). Hence -the instances - type instance XExpBr GhcTc = DataConCantHappen - ...etc... - -See the related Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice --} - data HsBracketTc = HsBracketTc - { brack_renamed_quote :: (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation] - , brack_ty :: Type - , brack_quote_wrapper :: (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument to the quote. - , brack_pending_splices :: [PendingTcSplice] -- Output of the type checker is the *original* - -- renamed expression, plus - -- _typechecked_ splices to be - -- pasted back in by the desugarer + { hsb_quote :: HsQuote GhcRn -- See Note [The life cycle of a TH quotation] + , hsb_ty :: Type + , hsb_wrap :: Maybe QuoteWrapper -- The wrapper to apply type and dictionary argument to the quote. + , hsb_splices :: [PendingTcSplice] -- Output of the type checker is the *original* + -- renamed expression, plus + -- _typechecked_ splices to be + -- pasted back in by the desugarer } type instance XTypedBracket GhcPs = EpAnn [AddEpAnn] @@ -326,7 +248,7 @@ type instance XApp (GhcPass _) = EpAnnCO -type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives +type instance XAppTypeE GhcPs = NoExtField type instance XAppTypeE GhcRn = NoExtField type instance XAppTypeE GhcTc = Type @@ -397,7 +319,10 @@ type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = RecordUpdTc +type instance XRecordUpd GhcTc = DataConCantHappen + -- We desugar record updates in the typechecker. + -- See [Handling overloaded and rebindable constructs], + -- and [Record Updates] in GHC.Tc.Gen.Expr. type instance XGetField GhcPs = EpAnnCO type instance XGetField GhcRn = NoExtField @@ -419,7 +344,6 @@ type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XSpliceE (GhcPass _) = EpAnnCO type instance XProc (GhcPass _) = EpAnn [AddEpAnn] type instance XStatic GhcPs = EpAnn [AddEpAnn] @@ -463,7 +387,7 @@ -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = EpAnn AnnPragma +type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel @@ -565,7 +489,9 @@ ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv ppr_expr (HsRecSel _ f) = pprPrefixOcc f ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ l) = char '#' <> ppr l +ppr_expr (HsOverLabel _ s l) = char '#' <> case s of + NoSourceText -> ppr l + SourceText src -> text src ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e) @@ -621,10 +547,10 @@ ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` + -- `MkSolo x`, not `(x)` | [Present _ expr] <- exprs , Boxed <- boxity - = hsep [text (mkTupleStr Boxed 1), ppr expr] + = hsep [text (mkTupleStr Boxed dataName 1), ppr expr] | otherwise = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) where @@ -713,7 +639,17 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsTypedSplice ext e) = + case ghcPass @p of + GhcPs -> pprTypedSplice Nothing e + GhcRn -> pprTypedSplice (Just ext) e + GhcTc -> pprTypedSplice Nothing e +ppr_expr (HsUntypedSplice ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ e <- ext -> ppr e + GhcTc -> dataConCantHappen ext ppr_expr (HsTypedBracket b e) = case ghcPass @p of @@ -797,7 +733,7 @@ -> SDoc ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args +ppr_apps (HsAppType _ (L _ fun) _ arg) args = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) where @@ -867,7 +803,8 @@ go (ExprWithTySig{}) = prec >= sigPrec go (ArithSeq{}) = False go (HsPragE{}) = prec >= appPrec - go (HsSpliceE{}) = False + go (HsTypedSplice{}) = False + go (HsUntypedSplice{}) = False go (HsTypedBracket{}) = False go (HsUntypedBracket{}) = False go (HsProc{}) = prec > topPrec @@ -937,7 +874,7 @@ isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where - ppr (HsPragSCC _ st (StringLiteral stl lbl _)) = + ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. @@ -1176,6 +1113,46 @@ -- wrap :: arg1 "->" arg2 -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxTable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious GHC.Rename.Expr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + data CmdTopTc = CmdTopTc Type -- Nested tuple of inputs on the command's stack Type -- return type of the command @@ -1185,6 +1162,7 @@ type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc + type instance XXCmdTop (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where @@ -1304,10 +1282,17 @@ ************************************************************************ -} -type instance XMG GhcPs b = NoExtField -type instance XMG GhcRn b = NoExtField +type instance XMG GhcPs b = Origin +type instance XMG GhcRn b = Origin type instance XMG GhcTc b = MatchGroupTc +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + , mg_origin :: Origin -- Origin (Generated vs FromSource) + } deriving Data + type instance XXMatchGroup (GhcPass _) b = DataConCantHappen type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn] @@ -1698,16 +1683,47 @@ ************************************************************************ -} -newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] -type instance XTypedSplice (GhcPass _) = EpAnn [AddEpAnn] -type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn] -type instance XQuasiQuote (GhcPass _) = NoExtField -type instance XSpliced (GhcPass _) = NoExtField -type instance XXSplice GhcPs = DataConCantHappen -type instance XXSplice GhcRn = DataConCantHappen -type instance XXSplice GhcTc = HsSplicedT +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +-- This is the result of splicing a splice. It is produced by +-- the renamer and consumed by the typechecker. It lives only between the two. +data HsUntypedSpliceResult thing -- 'thing' can be HsExpr or HsType + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice. + , utsplice_result :: thing -- ^ The result of splicing; See Note [Lifecycle of a splice] + } + | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point + +type instance XTypedSplice GhcPs = (EpAnnCO, EpAnn [AddEpAnn]) +type instance XTypedSplice GhcRn = SplicePointName +type instance XTypedSplice GhcTc = DelayedSplice + +type instance XUntypedSplice GhcPs = EpAnnCO +type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) +type instance XUntypedSplice GhcTc = DataConCantHappen + +-- HsUntypedSplice +type instance XUntypedSpliceExpr GhcPs = EpAnn [AddEpAnn] +type instance XUntypedSpliceExpr GhcRn = EpAnn [AddEpAnn] +type instance XUntypedSpliceExpr GhcTc = DataConCantHappen + +type instance XQuasiQuote p = NoExtField + +type instance XXUntypedSplice p = DataConCantHappen + -- See Note [Running typed splices in the zonker] -- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` data DelayedSplice = @@ -1726,6 +1742,13 @@ -- See Note [Pending Splices] type SplicePointName = Name +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + -- | Pending Renamer Splice data PendingRnSplice = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) @@ -1734,116 +1757,38 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) -{- -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~ -When we rename an untyped bracket, we name and lift out all the nested -splices, so that when the typechecker hits the bracket, it can -typecheck those nested splices without having to walk over the untyped -bracket code. So for example - [| f $(g x) |] -looks like - HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (HsUntypedSplice sn (g x))) - -which the renamer rewrites to - - HsUntypedBracket - [PendingRnSplice UntypedExpSplice sn (g x)] - (HsApp (HsVar f) (HsSpliceE _ (HsUntypedSplice sn (g x))) - -* The 'sn' is the Name of the splice point, the SplicePointName - -* The PendingRnExpSplice gives the splice that splice-point name maps to; - and the typechecker can now conveniently find these sub-expressions - -* Note that a nested splice, such as the `$(g x)` now appears twice: - - In the PendingRnSplice: this is the version that will later be typechecked - - In the HsSpliceE in the body of the bracket. This copy is used only for pretty printing. - -There are four varieties of pending splices generated by the renamer, -distinguished by their UntypedSpliceFlavour - - * Pending expression splices (UntypedExpSplice), e.g., - [|$(f x) + 2|] - - UntypedExpSplice is also used for - * quasi-quotes, where the pending expression expands to - $(quoter "...blah...") - (see GHC.Rename.Splice.makePending, HsQuasiQuote case) - - * cross-stage lifting, where the pending expression expands to - $(lift x) - (see GHC.Rename.Splice.checkCrossStageLifting) - - * Pending pattern splices (UntypedPatSplice), e.g., - [| \$(f x) -> x |] - - * Pending type splices (UntypedTypeSplice), e.g., - [| f :: $(g x) |] - - * Pending declaration (UntypedDeclSplice), e.g., - [| let $(f x) in ... |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - [||1 + $$(f 2)||] --} - -instance OutputableBndrId p - => Outputable (HsSplicedThing (GhcPass p)) where - ppr (HsSplicedExpr e) = ppr_expr e - ppr (HsSplicedTy t) = ppr t - ppr (HsSplicedPat p) = ppr p - -instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where - ppr s = pprSplice s - pprPendingSplice :: (OutputableBndrId p) => SplicePointName -> LHsExpr (GhcPass p) -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) -pprSpliceDecl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e -pprSpliceDecl e ImplicitSplice = ppr_splice_decl e - -ppr_splice_decl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SDoc -ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty -ppr_splice_decl e = pprSplice e +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprTypedSplice n e = ppr_splice (text "$$") n e -pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice _ DollarSplice n e) - = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice _ BareSplice _ _ ) - = panic "Bare typed splice" -- impossible -pprSplice (HsUntypedSplice _ DollarSplice n e) - = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice _ BareSplice n e) - = ppr_splice empty n e empty -pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ _ thing) = ppr thing -pprSplice (XSplice x) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> dataConCantHappen x - GhcRn -> dataConCantHappen x -#endif - GhcTc -> case x of - HsSplicedT _ -> text "Unevaluated typed splice" +pprUntypedSplice :: forall p. (OutputableBndrId p) + => Bool -- Whether to precede the splice with "$" + -> Maybe SplicePointName -- Used for pretty printing when exists + -> HsUntypedSplice (GhcPass p) + -> SDoc +pprUntypedSplice True n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e +pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e +pprUntypedSplice _ _ (HsQuasiQuote _ q s) = ppr_quasi q (unLoc s) -ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc -ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> - char '[' <> ppr quoter <> vbar <> +ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc +ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" ppr_splice :: (OutputableBndrId p) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc -ppr_splice herald n e trail - = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail + => SDoc + -> Maybe SplicePointName + -> LHsExpr (GhcPass p) + -> SDoc +ppr_splice herald mn e + = herald + <> (case mn of + Nothing -> empty + Just splice_name -> whenPprDebug (brackets (ppr splice_name))) + <> ppr e type instance XExpBr GhcPs = NoExtField @@ -1958,12 +1903,24 @@ LamCase -> "LamCase" LamCases -> "LamCases" +lamCaseKeyword :: LamCaseVariant -> SDoc +lamCaseKeyword LamCase = text "\\case" +lamCaseKeyword LamCases = text "\\cases" + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + instance Outputable HsArrowMatchContext where ppr ProcExpr = text "ProcExpr" ppr ArrowCaseAlt = text "ArrowCaseAlt" ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant ppr KappaExpr = text "KappaExpr" +pprHsArrType :: HsArrAppType -> SDoc +pprHsArrType HsHigherOrderApp = text "higher order arrow application" +pprHsArrType HsFirstOrderApp = text "first order arrow application" + ----------------- instance OutputableBndrId p @@ -2031,9 +1988,161 @@ , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator LamCaseAlt{} = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern + -- match checker trace +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) + => HsMatchContext p -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an (ArrowMatchCtxt ProcExpr) = True + want_an (ArrowMatchCtxt KappaExpr) = True + want_an _ = False + +pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) + => HsMatchContext p -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" + <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" + +pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) + => HsMatchContext p -> SDoc +pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" + <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) +pprMatchContextNouns PatBindGuards = text "pattern binding guards" +pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c +pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" + $$ pprAStmtContext ctxt +pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' + +pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" +pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" +pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternative within arrow notation" +pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction" + +pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" +pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternatives within arrow notation" +pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' + +----------------- +pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) + => HsStmtContext p -> SDoc +pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour +pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt + +----------------- +pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt +pprStmtContext ArrowExpr = text "'do' block in an arrow command" + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +pprStmtCat :: Stmt (GhcPass p) body -> SDoc +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" +pprStmtCat (ApplicativeStmt {}) = text "applicative" + +pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc +pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour + where + pp_an = text "an" + pp_a = text "a" + article = case flavour of + MDoExpr Nothing -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a +pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") +pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") +pprHsDoFlavour ListComp = text "list comprehension" +pprHsDoFlavour MonadComp = text "monad comprehension" +pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" + +prependQualified :: Maybe ModuleName -> SDoc -> SDoc +prependQualified Nothing t = t +prependQualified (Just _) t = text "qualified" <+> t + {- ************************************************************************ * * +FieldLabelStrings +* * +************************************************************************ +-} + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where + ppr (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unXRec @p) flds)) + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where + pprInfixOcc = pprFieldLabelStrings + pprPrefixOcc = pprFieldLabelStrings + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprInfixOcc . unLoc + +pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc +pprFieldLabelStrings (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unXRec @p) flds)) + +pprPrefixFastString :: FastString -> SDoc +pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) + +instance UnXRec p => Outputable (DotFieldOcc p) where + ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s + ppr XDotFieldOcc{} = text "XDotFieldOcc" + +{- +************************************************************************ +* * \subsection{Anno instances} * * ************************************************************************ @@ -2054,17 +2163,19 @@ type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcAnn NoEpAnns -type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA -type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA -type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns -type instance Anno (FieldLabelString) = SrcSpanAnnN -type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno FieldLabelString = SrcSpanAnnN + +type instance Anno FastString = SrcAnn NoEpAnns + -- Used in HsQuasiQuote and perhaps elsewhere + +type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns instance (Anno a ~ SrcSpanAnn' (EpAnn an)) => WrapXRec (GhcPass p) a where diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -1,3 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -10,16 +12,20 @@ import GHC.Utils.Outputable ( SDoc, Outputable ) import Language.Haskell.Syntax.Pat ( LPat ) import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable -import GHC.Types.Basic ( SpliceExplicitFlag(..)) import Language.Haskell.Syntax.Expr ( HsExpr, LHsExpr , HsCmd , MatchGroup , GRHSs - , HsSplice + , HsUntypedSplice ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import GHC.Types.Name ( Name ) +import Data.Bool ( Bool ) +import Data.Maybe ( Maybe ) +type SplicePointName = Name + instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) @@ -27,10 +33,8 @@ pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc - -pprSpliceDecl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc pprPatBind :: forall bndr p . (OutputableBndrId bndr, OutputableBndrId p) @@ -38,3 +42,12 @@ pprFunBind :: (OutputableBndrId idR) => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc + +data ThModFinalizers +type role HsUntypedSpliceResult representational +data HsUntypedSpliceResult thing + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers + , utsplice_result :: thing + } + | HsUntypedSpliceNested SplicePointName diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -11,10 +11,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension @@ -22,7 +25,10 @@ import GHC.Prelude +import GHC.TypeLits (KnownSymbol, symbolVal) + import Data.Data hiding ( Fixity ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader @@ -239,3 +245,20 @@ noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok = L NoTokenLoc HsNormalTok + +--- Outputable + +instance Outputable NoExtField where + ppr _ = text "NoExtField" + +instance Outputable DataConCantHappen where + ppr = dataConCantHappen + +instance KnownSymbol tok => Outputable (HsToken tok) where + ppr _ = text (symbolVal (Proxy :: Proxy tok)) + +instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where + ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) + ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) + +deriving instance Typeable p => Data (LayoutInfo (GhcPass p)) diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable and IEWrappedName {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,53 +16,43 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -module GHC.Hs.ImpExp where +module GHC.Hs.ImpExp + ( module Language.Haskell.Syntax.ImpExp + , module GHC.Hs.ImpExp + ) where import GHC.Prelude -import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) -import GHC.Hs.Doc import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc -import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension import GHC.Parser.Annotation +import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual import Data.Data import Data.Maybe +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp + {- ************************************************************************ * * -\subsection{Import and export declaration lists} + Import and export declaration lists * * ************************************************************************ -One per \tr{import} declaration in a module. +One per import declaration in a module. -} --- | Located Import Declaration -type LImportDecl pass = XRec pass (ImportDecl pass) - -- ^ When in a list this may have - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | If/how an import is 'qualified'. -data ImportDeclQualifiedStyle - = QualifiedPre -- ^ 'qualified' appears in prepositive position. - | QualifiedPost -- ^ 'qualified' appears in postpositive position. - | NotQualified -- ^ Not qualified. - deriving (Eq, Data) - -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from "GHC.Parser". @@ -77,56 +69,40 @@ isImportDeclQualified NotQualified = False isImportDeclQualified _ = True --- | Import Declaration --- --- A single Haskell @import@ declaration. -data ImportDecl pass - = ImportDecl { - ideclExt :: XCImportDecl pass, - ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in GHC.Types.SourceText - ideclName :: XRec pass ModuleName, -- ^ Module name. - ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. - ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import - ideclSafe :: Bool, -- ^ True => safe import - ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. - ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) - ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module - ideclHiding :: Maybe (Bool, XRec pass [LIE pass]) - -- ^ (True => hiding, names) - } - | XImportDecl !(XXImportDecl pass) - -- ^ - -- 'GHC.Parser.Annotation.AnnKeywordId's - -- - -- - 'GHC.Parser.Annotation.AnnImport' - -- - -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource - -- - -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified', - -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs', - -- 'GHC.Parser.Annotation.AnnVal' - -- - -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' attached - -- to location in ideclHiding - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -type family ImportDeclPkgQual pass type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual -type instance XCImportDecl GhcPs = EpAnn EpAnnImportDecl -type instance XCImportDecl GhcRn = NoExtField -type instance XCImportDecl GhcTc = NoExtField +type instance XCImportDecl GhcPs = XImportDeclPass +type instance XCImportDecl GhcRn = XImportDeclPass +type instance XCImportDecl GhcTc = DataConCantHappen + -- Note [Pragma source text] in GHC.Types.SourceText +data XImportDeclPass = XImportDeclPass + { ideclAnn :: EpAnn EpAnnImportDecl + , ideclSourceText :: SourceText + , ideclImplicit :: Bool + -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude` + -- that appears in any file that omits `import Prelude`, setting + -- this field to indicate that the import doesn't appear in the + -- original source. True => implicit import (of Prelude) + } + deriving (Data) + type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL +deriving instance Data (IEWrappedName GhcPs) +deriving instance Data (IEWrappedName GhcRn) +deriving instance Data (IEWrappedName GhcTc) + +deriving instance Eq (IEWrappedName GhcPs) +deriving instance Eq (IEWrappedName GhcRn) +deriving instance Eq (IEWrappedName GhcTc) + -- --------------------------------------------------------------------- -- API Annotations types @@ -144,33 +120,36 @@ simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl { - ideclExt = noAnn, - ideclSourceSrc = NoSourceText, - ideclName = noLocA mn, - ideclPkgQual = NoRawPkgQual, - ideclSource = NotBoot, - ideclSafe = False, - ideclImplicit = False, - ideclQualified = NotQualified, - ideclAs = Nothing, - ideclHiding = Nothing + ideclExt = XImportDeclPass noAnn NoSourceText False, + ideclName = noLocA mn, + ideclPkgQual = NoRawPkgQual, + ideclSource = NotBoot, + ideclSafe = False, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclImportList = Nothing } instance (OutputableBndrId p , Outputable (Anno (IE (GhcPass p))) , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where - ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' + ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe - , ideclQualified = qual, ideclImplicit = implicit - , ideclAs = as, ideclHiding = spec }) - = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, + , ideclQualified = qual + , ideclAs = as, ideclImportList = spec }) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) 4 (pp_spec spec) where - pp_implicit False = empty - pp_implicit True = text "(implicit)" + pp_implicit ext = + let implicit = case ghcPass @p of + GhcPs | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcRn | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcTc -> dataConCantHappen ext + in if implicit then text "(implicit)" + else empty pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. @@ -184,14 +163,19 @@ pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a - ppr_imp IsBoot = case mSrcText of - NoSourceText -> text "{-# SOURCE #-}" - SourceText src -> text src <+> text "#-}" - ppr_imp NotBoot = empty + ppr_imp ext IsBoot = + let mSrcText = case ghcPass @p of + GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcTc -> dataConCantHappen ext + in case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> text src <+> text "#-}" + ppr_imp _ NotBoot = empty pp_spec Nothing = empty - pp_spec (Just (False, (L _ ies))) = ppr_ies ies - pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies + pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies + pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' @@ -204,86 +188,15 @@ ************************************************************************ -} --- | A name in an import or export specification which may have --- adornments. Used primarily for accurate pretty printing of --- ParsedSource, and API Annotation placement. The --- 'GHC.Parser.Annotation' is the location of the adornment in --- the original source. -data IEWrappedName name - = IEName (LocatedN name) -- ^ no extra - | IEPattern EpaLocation (LocatedN name) -- ^ pattern X - | IEType EpaLocation (LocatedN name) -- ^ type (:+:) - deriving (Eq,Data) - --- | Located name with possible adornment --- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', --- 'GHC.Parser.Annotation.AnnPattern' -type LIEWrappedName name = LocatedA (IEWrappedName name) --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - +type instance XIEName (GhcPass _) = NoExtField +type instance XIEPattern (GhcPass _) = EpaLocation +type instance XIEType (GhcPass _) = EpaLocation +type instance XXIEWrappedName (GhcPass _) = DataConCantHappen --- | Located Import or Export -type LIE pass = XRec pass (IE pass) - -- ^ When in a list this may have - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' +type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (IE (GhcPass p)) = SrcSpanAnnA --- | Imported or exported entity. -data IE pass - = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or Exported Variable - - | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or exported Thing with Absent list - -- - -- The thing is a Class/Type (can't tell) - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern', - -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- See Note [Located RdrNames] in GHC.Hs.Expr - | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or exported Thing with All imported or exported - -- - -- The thing is a Class/Type and the All refers to methods/constructors - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose', - -- 'GHC.Parser.Annotation.AnnType' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- See Note [Located RdrNames] in GHC.Hs.Expr - - | IEThingWith (XIEThingWith pass) - (LIEWrappedName (IdP pass)) - IEWildcard - [LIEWrappedName (IdP pass)] - -- ^ Imported or exported Thing With given imported or exported - -- - -- The thing is a Class/Type and the imported or exported things are - -- methods/constructors and record fields; see Note [IEThingWith] - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose', - -- 'GHC.Parser.Annotation.AnnComma', - -- 'GHC.Parser.Annotation.AnnType' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) - -- ^ Imported or exported module contents - -- - -- (Export Only) - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading - | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation - | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc - | XIE !(XXIE pass) - type instance XIEVar GhcPs = NoExtField type instance XIEVar GhcRn = NoExtField type instance XIEVar GhcTc = NoExtField @@ -307,9 +220,6 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA --- | Imported or Exported Wildcard -data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) - {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~ @@ -355,27 +265,27 @@ ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieWrappedLName :: IEWrappedName name -> LocatedN name -ieWrappedLName (IEName ln) = ln -ieWrappedLName (IEPattern _ ln) = ln -ieWrappedLName (IEType _ ln) = ln +ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p) +ieWrappedLName (IEName _ (L l n)) = L l n +ieWrappedLName (IEPattern _ (L l n)) = L l n +ieWrappedLName (IEType _ (L l n)) = L l n -ieWrappedName :: IEWrappedName name -> name +ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName -lieWrappedName :: LIEWrappedName name -> name +lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> LocatedN name +ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p) ieLWrappedName (L _ n) = ieWrappedLName n -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 -replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn +replaceWrappedName (IEName x (L l _)) n = IEName x (L l n) replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) replaceWrappedName (IEType r (L l _)) n = IEType r (L l n) -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 +replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') instance OutputableBndrId p => Outputable (IE (GhcPass p)) where @@ -403,18 +313,18 @@ ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("") -instance (HasOccName name) => HasOccName (IEWrappedName name) where +instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where occName w = occName (ieWrappedName w) -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where +instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where pprBndr bs w = pprBndr bs (ieWrappedName w) pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) pprInfixOcc w = pprInfixOcc (ieWrappedName w) -instance (OutputableBndr name) => Outputable (IEWrappedName name) where - ppr (IEName n) = pprPrefixOcc (unLoc n) - ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n) - ppr (IEType _ n) = text "type" <+> pprPrefixOcc (unLoc n) +instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where + ppr (IEName _ (L _ n)) = pprPrefixOcc n + ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n + ppr (IEType _ (L _ n)) = text "type" <+> pprPrefixOcc n pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -231,6 +231,16 @@ deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (ForeignImport p) +deriving instance Data (ForeignImport GhcPs) +deriving instance Data (ForeignImport GhcRn) +deriving instance Data (ForeignImport GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignExport p) +deriving instance Data (ForeignExport GhcPs) +deriving instance Data (ForeignExport GhcRn) +deriving instance Data (ForeignExport GhcTc) + -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn) @@ -373,15 +383,12 @@ deriving instance Data (HsMatchContext GhcRn) deriving instance Data (HsMatchContext GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplice p) -deriving instance Data (HsSplice GhcPs) -deriving instance Data (HsSplice GhcRn) -deriving instance Data (HsSplice GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p) +deriving instance Data (HsUntypedSplice GhcPs) +deriving instance Data (HsUntypedSplice GhcRn) +deriving instance Data (HsUntypedSplice GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) -deriving instance Data (HsSplicedThing GhcPs) -deriving instance Data (HsSplicedThing GhcRn) -deriving instance Data (HsSplicedThing GhcTc) +deriving instance Data a => Data (HsUntypedSpliceResult a) -- deriving instance (DataIdLR p p) => Data (HsQuote p) deriving instance Data (HsQuote GhcPs) @@ -395,7 +402,6 @@ deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice deriving instance Data PendingTcSplice @@ -431,6 +437,10 @@ deriving instance Data ConPatTc +deriving instance Data (HsConPatTyArg GhcPs) +deriving instance Data (HsConPatTyArg GhcRn) +deriving instance Data (HsConPatTyArg GhcTc) + deriving instance (Data a, Data b) => Data (HsFieldBind a b) deriving instance (Data body) => Data (HsRecFields GhcPs body) @@ -479,6 +489,11 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTyLit p) +deriving instance Data (HsTyLit GhcPs) +deriving instance Data (HsTyLit GhcRn) +deriving instance Data (HsTyLit GhcTc) -- deriving instance Data (HsLinearArrowTokens p) deriving instance Data (HsLinearArrowTokens GhcPs) diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -25,14 +25,15 @@ import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import Language.Haskell.Syntax.Lit - +import GHC.Types.Basic (PprPrec(..), topPrec ) +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable +import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension +import Language.Haskell.Syntax.Lit {- ************************************************************************ @@ -103,6 +104,40 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +-- +-- See Note [Printing of literals in Core] in GHC.Types.Literal +-- for the reasoning. +hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsIntPrim {}) = False + go (HsWordPrim {}) = False + go (HsInt64Prim {}) = False + go (HsWord64Prim {}) = False + go (HsInteger _ x _) = p > topPrec && x < 0 + go (HsRat _ x _) = p > topPrec && fl_neg x + go (HsFloatPrim {}) = False + go (HsDoublePrim {}) = False + go (XLit _) = False + -- | Convert a literal from one index type to another convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) convertLit (HsChar a x) = HsChar a x @@ -137,7 +172,7 @@ -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) @@ -148,12 +183,8 @@ ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - -pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc -pp_st_suffix NoSourceText _ doc = doc -pp_st_suffix (SourceText st) suffix _ = text st <> suffix + ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p @@ -161,6 +192,11 @@ ppr (OverLit {ol_val=val, ol_ext=ext}) = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext))) +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens @@ -181,3 +217,4 @@ pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d + diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -28,9 +29,11 @@ XXPatGhcTc(..), HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, @@ -53,7 +56,7 @@ import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Expr ( HsExpr ) -import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) +import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprUntypedSplice, HsUntypedSpliceResult(..)) -- friends: import GHC.Hs.Binds @@ -78,7 +81,7 @@ import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats import GHC.Data.Maybe -import GHC.Types.Name (Name) +import GHC.Types.Name (Name, dataName) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import Data.Data @@ -94,7 +97,7 @@ type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@' +type instance XAsPat GhcPs = EpAnnCO type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField @@ -137,7 +140,7 @@ -- (= the argument type of the view function), for hsPatType. type instance XSplicePat GhcPs = NoExtField -type instance XSplicePat GhcRn = NoExtField +type instance XSplicePat GhcRn = HsUntypedSpliceResult (Pat GhcRn) -- See Note [Lifecycle of a splice] in GHC.Hs.Expr type instance XSplicePat GhcTc = DataConCantHappen type instance XLitPat (GhcPass _) = NoExtField @@ -259,6 +262,24 @@ ************************************************************************ -} +instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where + ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty + +instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, OutputableBndr p, Outputable arg) + => Outputable (HsFieldBind p arg) where + ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, + hfbPun = pun }) + = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) + instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat @@ -307,7 +328,7 @@ pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat -pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', +pprPat (AsPat _ name _ pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat _ _ pat _) = parens (ppr pat) @@ -319,15 +340,20 @@ GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n -pprPat (SplicePat _ splice) = pprSplice splice +pprPat (SplicePat ext splice) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing splice + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) splice + GhcRn | HsUntypedSpliceTop _ p <- ext -> ppr p + GhcTc -> dataConCantHappen ext pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` + -- `MkSolo x`, not `(x)` | [pat] <- pats , Boxed <- bx - = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat] + = hcat [text (mkTupleStr Boxed dataName 1), pprParendLPat appPrec pat] | otherwise = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) @@ -377,7 +403,7 @@ Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats) - where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs) + where pprTyArgs tyargs = fsep (map ppr tyargs) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats @@ -470,7 +496,7 @@ looksLazyPat :: Pat (GhcPass p) -> Bool looksLazyPat (ParPat _ _ p _) = looksLazyLPat p -looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False @@ -537,7 +563,7 @@ | otherwise = True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat - go (AsPat _ _ pat) = goL pat + go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat go (TuplePat _ pats _) = all goL pats @@ -694,7 +720,7 @@ collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ p -> collectEvVarsLPat p + AsPat _ _ _ p -> collectEvVarsLPat p ParPat _ _ p _ -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps @@ -728,3 +754,4 @@ type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA +type instance Anno RecFieldsDotDot = SrcSpan diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -91,28 +92,32 @@ import Language.Haskell.Syntax.Type -import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice ) +import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) import Language.Haskell.Syntax.Extension +import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Fixity ( LexicalFixity(..) ) import GHC.Types.Id ( Id ) import GHC.Types.SourceText -import GHC.Types.Name( Name, NamedThing(getName) ) +import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName ) 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.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Utils.Misc (count) import Data.Maybe +import Data.Data (Data) import qualified Data.Semigroup as S @@ -202,10 +207,18 @@ type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen -type instance XHsPS GhcPs = EpAnn EpaLocation +type instance XHsPS GhcPs = EpAnnCO type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +-- | The extension field for 'HsPatSigType', which is only used in the +-- renamer onwards. See @Note [Pattern signature binders and scoping]@. +data HsPSRn = HsPSRn + { hsps_nwcs :: [Name] -- ^ Wildcard names + , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names + } + deriving Data + type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XHsSig (GhcPass _) = NoExtField @@ -251,7 +264,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs mkHsPatSigType ann x = HsPS { hsps_ext = ann , hsps_body = x } @@ -302,7 +315,7 @@ type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives type instance XSpliceTy GhcPs = NoExtField -type instance XSpliceTy GhcRn = NoExtField +type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] @@ -326,7 +339,20 @@ type instance XXType (GhcPass _) = HsCoreTy +-- An escape hatch for tunnelling a Core 'Type' through 'HsType'. +-- For more details on how this works, see: +-- +-- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" +-- +-- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" +type HsCoreTy = Type +type instance XNumTy (GhcPass _) = SourceText +type instance XStrTy (GhcPass _) = SourceText +type instance XCharTy (GhcPass _) = SourceText +type instance XXTyLit (GhcPass _) = DataConCantHappen + + oneDataConHsTy :: HsType GhcRn oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) @@ -358,9 +384,9 @@ -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc -pprHsArrow (HsUnrestrictedArrow _) = arrow -pprHsArrow (HsLinearArrow _) = lollipop -pprHsArrow (HsExplicitMult _ p _) = mulArrow (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 @@ -532,6 +558,66 @@ -------------------------------- +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-------------------------------- + +-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ +-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix +-- or infix. Examples: +-- +-- @ +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering +-- @ +pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) + => id -> LexicalFixity -> [HsArg tm ty] -> SDoc +pprHsArgsApp thing fixity (argl:argr:args) + | Infix <- fixity + = let pp_op_app = hsep [ ppr_single_hs_arg argl + , pprInfixOcc thing + , ppr_single_hs_arg argr ] in + case args of + [] -> pp_op_app + _ -> ppr_hs_args_prefix_app (parens pp_op_app) args + +pprHsArgsApp thing _fixity args + = ppr_hs_args_prefix_app (pprPrefixOcc thing) args + +-- | Pretty-print a prefix identifier to a list of 'HsArg's. +ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) + => SDoc -> [HsArg tm ty] -> SDoc +ppr_hs_args_prefix_app acc [] = acc +ppr_hs_args_prefix_app acc (arg:args) = + case arg of + HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args + +-- | Pretty-print an 'HsArg' in isolation. +ppr_single_hs_arg :: (Outputable tm, Outputable ty) + => HsArg tm ty -> SDoc +ppr_single_hs_arg (HsValArg tm) = ppr tm +ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty +-- GHC shouldn't be constructing ASTs such that this case is ever reached. +-- Still, it's possible some wily user might construct their own AST that +-- allows this to be reachable, so don't fail here. +ppr_single_hs_arg (HsArgPar{}) = empty + +-- | This instance is meant for debug-printing purposes. If you wish to +-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp + +-------------------------------- + -- | Decompose a pattern synonym type signature into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types @@ -918,6 +1004,42 @@ => Outputable (HsPatSigType (GhcPass p)) where ppr (HsPS { hsps_body = ty }) = ppr ty + +instance (OutputableBndrId p) + => Outputable (HsTyLit (GhcPass p)) where + ppr = ppr_tylit + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +instance (Outputable tyarg, Outputable arg, Outputable rec) + => Outputable (HsConDetails tyarg arg rec) where + ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where + ppr = ppr . foLabel + +instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where + pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel + pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel + +instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + + +ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc +ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) +ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) + pprAnonWildCard :: SDoc pprAnonWildCard = char '_' @@ -1007,7 +1129,7 @@ => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty }) = sep [pprHsForAll tele Nothing, ppr_mono_lty ty] @@ -1023,7 +1145,7 @@ -- `Solo x`, not `(x)` | [ty] <- tys , BoxedTuple <- std_con - = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty] | otherwise = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of @@ -1035,15 +1157,20 @@ = ppr_mono_lty ty <+> dcolon <+> ppr kind ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsSpliceTy ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ t <- ext -> ppr t + GhcTc -> pprUntypedSplice True Nothing s ppr_mono_ty (HsExplicitListTy _ prom tys) | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) | otherwise = brackets (interpp'SP tys) ppr_mono_ty (HsExplicitTupleTy _ tys) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `'Solo x`, not `'(x)` + -- `'MkSolo x`, not `'(x)` | [ty] <- tys - = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + = quote $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty] | otherwise = quote $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t) = ppr t @@ -1106,7 +1233,7 @@ go_hs_ty (HsSpliceTy{}) = False go_hs_ty (HsExplicitListTy{}) = False -- Special-case unary boxed tuple applications so that they are - -- parenthesized as `Proxy ('Solo x)`, not `Proxy 'Solo x` (#18612) + -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types go_hs_ty (HsExplicitTupleTy _ [_]) = p >= appPrec diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -55,10 +55,6 @@ mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkLocatedList, - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, chunkify, - -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, @@ -66,7 +62,7 @@ spanHsLocaLBinds, -- * Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit, mkHsCharPrimLit, -- * Patterns @@ -89,10 +85,6 @@ unitRecStmtTc, mkLetStmt, - -- * Template Haskell - mkUntypedSplice, mkTypedSplice, - mkHsQuasiQuote, - -- * Collecting binders isUnliftedHsBind, isBangedHsBind, @@ -113,7 +105,7 @@ lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs.Decls import GHC.Hs.Binds @@ -126,12 +118,16 @@ 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 ) @@ -142,17 +138,20 @@ 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 import GHC.Utils.Panic import Data.Either +import Data.Foldable ( toList ) import Data.Function import Data.List ( partition, deleteBy ) +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -200,7 +199,7 @@ unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] type AnnoBody p body - = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField + = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA ) @@ -209,9 +208,8 @@ => Origin -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) -mkMatchGroup origin matches = MG { mg_ext = noExtField - , mg_alts = matches - , mg_origin = origin } +mkMatchGroup origin matches = MG { mg_ext = origin + , mg_alts = matches } mkLamCaseMatchGroup :: AnnoBody p body => Origin @@ -224,8 +222,9 @@ mkLocatedList :: Semigroup a => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] -mkLocatedList [] = noLocA [] -mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms +mkLocatedList ms = case nonEmpty ms of + Nothing -> noLocA [] + Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2) @@ -249,7 +248,7 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) +mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } @@ -257,7 +256,7 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) @@ -269,7 +268,7 @@ 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 @@ -345,13 +344,17 @@ ~ SrcSpanAnnL) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) -mkRecStmt :: (Anno [GenLocated + +mkRecStmt :: forall (idL :: Pass) bodyR. + (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL) => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR +mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) + { recS_stmts = stmts } mkHsIntegral i = OverLit noExtField (HsIntegral i) @@ -411,7 +414,7 @@ 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 . @@ -438,7 +441,6 @@ emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts } mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds @@ -449,22 +451,12 @@ mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 -unqualSplice :: RdrName -unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e - -mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e - -mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote - = HsQuasiQuote noExtField unqualSplice quoter span quote - mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) +mkHsStringFS :: FastString -> HsLit (GhcPass p) +mkHsStringFS s = HsString NoSourceText s + mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) @@ -670,7 +662,7 @@ mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLocA $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed +mkLHsPatTup lpats@(lpat:_) = L (getLoc lpat) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: IsSrcSpanAnn p a @@ -689,47 +681,6 @@ 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) - {- ************************************************************************ * * @@ -823,7 +774,7 @@ | 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 @@ -845,7 +796,7 @@ = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = noExtField - , fun_tick = [] } + } mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn @@ -854,7 +805,7 @@ , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = emptyNameSet -- NB: closed -- binding - , fun_tick = [] } + } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs @@ -877,7 +828,7 @@ -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind { fun_matches = MG _ matches _ }) +isInfixFunBind (FunBind { fun_matches = MG _ matches }) = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) isInfixFunBind _ = False @@ -1203,7 +1154,7 @@ WildPat _ -> bndrs LazyPat _ pat -> collect_lpat flag pat bndrs BangPat _ pat -> collect_lpat flag pat bndrs - AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs + AsPat _ a _ pat -> unXRec @p a : collect_lpat flag pat bndrs ViewPat _ _ pat -> collect_lpat flag pat bndrs ParPat _ _ pat _ -> collect_lpat flag pat bndrs ListPat _ pats -> foldr (collect_lpat flag) bndrs pats @@ -1214,9 +1165,7 @@ NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs SigPat _ pat _ -> collect_lpat flag pat bndrs XPat ext -> collectXXPat @p flag ext bndrs - SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)) - -> collect_pat flag pat bndrs - SplicePat _ _ -> bndrs + SplicePat ext _ -> collectXSplicePat @p flag ext bndrs -- See Note [Dictionary binders in ConPatOut] ConPat {pat_args=ps} -> case flag of CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) @@ -1242,6 +1191,7 @@ class UnXRec p => CollectPass p where collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p] + collectXSplicePat :: CollectFlag p -> XSplicePat p -> [IdP p] -> [IdP p] instance IsPass p => CollectPass (GhcPass p) where collectXXPat flag ext = @@ -1263,7 +1213,14 @@ -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk + collectXSplicePat flag ext = + case ghcPass @p of + GhcPs -> id + GhcRn | (HsUntypedSpliceTop _ pat) <- ext -> collect_pat flag pat + GhcRn | (HsUntypedSpliceNested _) <- ext -> id + GhcTc -> dataConCantHappen ext + {- Note [Dictionary binders in ConPatOut] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1448,7 +1405,7 @@ => HsDataDefn (GhcPass p) -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons + = hsConDeclsBinders (toList cons) -- See Note [Binders in family instances] ------------------- @@ -1475,7 +1432,7 @@ -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (map (L loc . unLoc) names ++ ns, flds ++ fs) + -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs) where (remSeen', flds) = get_flds_gadt remSeen args (ns, fs) = go remSeen' rs @@ -1593,7 +1550,7 @@ hs_pat (LazyPat _ pat) = hs_lpat pat hs_pat (BangPat _ pat) = hs_lpat pat - hs_pat (AsPat _ _ pat) = hs_lpat pat + hs_pat (AsPat _ _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat hs_pat (ParPat _ _ pat _) = hs_lpat pat hs_pat (ListPat _ pats) = hs_lpats pats @@ -1618,7 +1575,7 @@ (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld | (i, fld) <- [0..] `zip` rec_flds fs , let pat_explicit = - maybe True ((i<) . unLoc) + maybe True ((i<) . unRecFieldsDotDot . unLoc) (rec_dotdot fs)] err_loc = maybe (getLocA n) getLoc (rec_dotdot fs) diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where @@ -11,6 +15,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -20,9 +25,11 @@ instance Diagnostic DsMessage where - diagnosticMessage = \case - DsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + DsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" DsIdentitiesFound conv_fn type_of_conv @@ -79,7 +86,7 @@ hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind) DsUselessSpecialiseForClassMethodSelector poly_id -> mkSimpleDecorated $ - text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) + text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id) DsUselessSpecialiseForNoInlineFunction poly_id -> mkSimpleDecorated $ text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) @@ -111,8 +118,6 @@ | isTyVar b = text "type variable" <+> quotes (ppr b) | isEvVar b = text "constraint" <+> quotes (ppr (varType b)) | otherwise = text "variable" <+> quotes (ppr b) - DsMultipleConForNewtype names - -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs -> mkSimpleDecorated $ hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ @@ -223,7 +228,6 @@ DsRuleLhsTooComplicated{} -> WarningWithoutFlag DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag DsRuleBindersNotBound{} -> WarningWithoutFlag - DsMultipleConForNewtype{} -> ErrorWithoutFlag DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag DsNotYetHandledByTH{} -> ErrorWithoutFlag DsAggregatedViewExpressions{} -> WarningWithoutFlag @@ -235,7 +239,7 @@ DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing - diagnosticHints = \case + diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m DsEmptyEnumeration -> noHints DsIdentitiesFound{} -> noHints @@ -260,7 +264,6 @@ DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints DsRuleBindersNotBound{} -> noHints - DsMultipleConForNewtype{} -> noHints DsLazyPatCantBindVarsOfUnliftedType{} -> noHints DsNotYetHandledByTH{} -> noHints DsAggregatedViewExpressions{} -> noHints @@ -271,6 +274,8 @@ DsRecBindsNotAllowedForUnliftedTys{} -> noHints DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + + diagnosticCode = constructorCode {- Note [Suggest NegativeLiterals] diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} module GHC.HsToCore.Errors.Types where -import Data.Typeable - import GHC.Prelude import GHC.Core (CoreRule, CoreExpr, RuleName) @@ -19,6 +19,8 @@ import GHC.Types.Name (Name) import qualified GHC.LanguageExtensions as LangExt +import GHC.Generics (Generic) + newtype MinBound = MinBound Integer newtype MaxBound = MaxBound Integer type MaxUncoveredPatterns = Int @@ -27,7 +29,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage -- | Simply wraps a generic 'Diagnostic' message. - = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a + = DsUnknownMessage UnknownDiagnostic {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is emitted if an enumeration is empty. @@ -122,8 +124,6 @@ !CoreExpr -- ^ The optimised LHS - | DsMultipleConForNewtype [LocatedN Name] - | DsLazyPatCantBindVarsOfUnliftedType [Var] | DsNotYetHandledByTH !ThRejectionReason @@ -145,6 +145,8 @@ | DsAnotherRuleMightFireFirst !RuleName !RuleName -- the \"bad\" rule !Var + + deriving Generic -- The positional number of the argument for an expression (first, second, third, etc) newtype DsArgNum = DsArgNum Int diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs --- a/compiler/GHC/HsToCore/Pmc/Ppr.hs +++ b/compiler/GHC/HsToCore/Pmc/Ppr.hs @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for +-- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.Pmc.Ppr ( pprUncovered @@ -10,6 +9,8 @@ import GHC.Prelude +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Var.Env @@ -101,12 +102,11 @@ attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x)) -type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a +type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a -- Try nice names p,q,r,s,t before using the (ugly) t_i -nameList :: [SDoc] -nameList = map text ["p","q","r","s","t"] ++ - [ text ('t':show u) | u <- [(0 :: Int)..] ] +nameList :: Infinite SDoc +nameList = map text ["p","q","r","s","t"] Inf.++ flip Inf.unfoldr (0 :: Int) (\ u -> (text ('t':show u), u+1)) runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc)) runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of @@ -117,7 +117,7 @@ getCleanName :: Id -> PmPprM SDoc getCleanName x = do (renamings, name_supply) <- get - let (clean_name:name_supply') = name_supply + let Inf clean_name name_supply' = name_supply case lookupDVarEnv renamings x of Just (_, nm) -> pure nm Nothing -> do diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -57,6 +57,7 @@ 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 @@ -348,9 +349,9 @@ lookupSolution :: Nabla -> Id -> Maybe PmAltConApp lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of [] -> Nothing - pos + pos@(x:_) | Just sol <- find isDataConSolution pos -> Just sol - | otherwise -> Just (head pos) + | otherwise -> Just x -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that @@ -766,7 +767,7 @@ instance Outputable PmLitValue where ppr (PmLitInt i) = ppr i - ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough + ppr (PmLitRat r) = double (fromRat r) -- good enough ppr (PmLitChar c) = pprHsChar c ppr (PmLitString s) = pprHsString s ppr (PmLitOverInt n i) = minuses n (ppr i) diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs --- a/compiler/GHC/Iface/Recomp/Binary.hs +++ b/compiler/GHC/Iface/Recomp/Binary.hs @@ -1,6 +1,6 @@ --- | Computing fingerprints of values serializeable with GHC's \"Binary\" module. +-- | Computing fingerprints of values serializable with GHC's \"Binary\" module. module GHC.Iface.Recomp.Binary ( -- * Computing fingerprints fingerprintBinMem diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -5,15 +5,16 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Iface.Syntax ( module GHC.Iface.Type, IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding, + IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..), + IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceClassBody(..), @@ -22,7 +23,7 @@ IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), - IfaceLFInfo(..), + IfaceLFInfo(..), IfaceTopBndrInfo(..), -- * Binding names IfaceTopBndr, @@ -43,7 +44,8 @@ import GHC.Prelude -import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey ) +import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, + constraintKindTyConKey ) import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -63,8 +65,8 @@ 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 @@ -78,6 +80,8 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, seqList, zipWithEqual ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Control.Monad import System.IO.Unsafe import Control.DeepSeq @@ -115,6 +119,7 @@ --pprTrace "putIfaceTopBndr" (ppr name) $ put_binding_name bh name + data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, @@ -232,7 +237,9 @@ data IfaceConDecls = IfAbstractTyCon -- c.f TyCon.AbstractTyCon - | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfDataTyCon !Bool [IfaceConDecl] -- Data type decls + -- The Bool is True for "type data" declarations. + -- see Note [Type data declarations] in GHC.Rename.Module | IfNewTyCon IfaceConDecl -- Newtype decls -- For IfDataTyCon and IfNewTyCon we store: @@ -351,7 +358,6 @@ | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs - | HsLevity -- Present <=> never representation-polymorphic | HsLFInfo IfaceLFInfo | HsTagSig TagSig @@ -359,23 +365,17 @@ -- only later attached to the Id. Partial reason: some are orphans. data IfaceUnfolding - = IfCoreUnfold Bool IfUnfoldingCache IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding - -- Possibly could eliminate the Bool here, the information - -- is also in the InlinePragma. - - | IfCompulsory IfaceExpr -- default methods and unsafeCoerce# - -- for more about unsafeCoerce#, see - -- Note [Wiring in unsafeCoerce#] in "GHC.HsToCore" - - | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring + = IfCoreUnfold UnfoldingSource + IfUnfoldingCache -- See Note [Tying the 'CoreUnfolding' knot] + IfGuidance IfaceExpr - | IfDFunUnfold [IfaceBndr] [IfaceExpr] type IfUnfoldingCache = UnfoldingCache +data IfGuidance + = IfNoGuidance -- Compute it from the IfaceExpr + | IfWhen Arity Bool Bool -- Just like UnfWhen in Core.UnfoldingGuidance -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection. Notably, none of the @@ -458,7 +458,7 @@ visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfDataTyCon _ cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] @@ -467,18 +467,23 @@ -- especially the question of whether there's a wrapper for a datacon -- See Note [Implicit TyThings] in GHC.Driver.Env --- N.B. the set of names returned here *must* match the set of --- TyThings returned by GHC.Driver.Env.implicitTyThings, in the sense that +-- N.B. the set of names returned here *must* match the set of TyThings +-- returned by GHC.Types.TyThing.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint (see note --- [Tricky iface loop]) +-- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint +-- (see Note [Tricky iface loop] in GHC.Types.TyThing.) -- The order of the list does not matter. ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) = case cons of IfAbstractTyCon {} -> [] IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd - IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds + IfDataTyCon type_data cds + | type_data -> + -- Constructors in "type data" declarations have no implicits. + -- see Note [Type data declarations] in GHC.Rename.Module + [occName con_name | IfCon { ifConName = con_name } <- cds] + | otherwise -> concatMap ifaceConDeclImplicitBndrs cds ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) = [] @@ -558,11 +563,11 @@ | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding 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 @@ -581,15 +586,24 @@ | IfaceDataAlt IfExtName | IfaceLitAlt Literal -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] +type IfaceBinding b = IfaceBindingX IfaceExpr b +data IfaceBindingX r b + = IfaceNonRec b r + | IfaceRec [(b, r)] + deriving (Functor, Foldable, Traversable, Ord, Eq) + -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo +data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails + | IfGblTopBndr IfaceTopBndr + +-- See Note [Interface File with Core: Sharing RHSs] +data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr + data IfaceJoinInfo = IfaceNotJoinPoint | IfaceJoinPoint JoinArity @@ -706,8 +720,24 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl showToIface +instance (Outputable r, Outputable b) => Outputable (IfaceBindingX r b) where + ppr b = case b of + (IfaceNonRec b r) -> ppr_bind (b, r) + (IfaceRec pairs) -> sep [text "rec {", nest 2 (sep (map ppr_bind pairs)),text "}"] + where + ppr_bind (b, r) = ppr b <+> equals <+> ppr r + +instance Outputable IfaceTopBndrInfo where + ppr (IfLclTopBndr lcl_name _ _ _) = ppr lcl_name + ppr (IfGblTopBndr gbl) = ppr gbl + +instance Outputable IfaceMaybeRhs where + ppr IfUseUnfoldingRhs = text "" + ppr (IfRhs ie) = ppr ie + {- -Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Minimal complete definition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The minimal complete definition should only be included if a complete class definition is shown. Since the minimal complete definition is anonymous we can't reuse the same mechanism that is used for the @@ -767,7 +797,7 @@ ppShowIface _ _ = Outputable.empty -- show if all sub-components or the complete interface is shown -ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition] ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc ppShowAllSubs _ _ = Outputable.empty @@ -841,7 +871,7 @@ 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 @@ -890,6 +920,7 @@ pp_nd = case condecls of IfAbstractTyCon{} -> text "data" + IfDataTyCon True _ -> text "type data" IfDataTyCon{} -> text "data" IfNewTyCon{} -> text "newtype" @@ -963,7 +994,8 @@ -- See Note [Printing type abbreviations] in GHC.Iface.Type ppr_tau | tc `hasKey` liftedTypeKindTyConKey || - tc `hasKey` unrestrictedFunTyConKey + tc `hasKey` unrestrictedFunTyConKey || + tc `hasKey` constraintKindTyConKey = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau | otherwise = ppr tau @@ -1048,7 +1080,8 @@ , 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 @@ -1187,16 +1220,18 @@ -- 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 '!' @@ -1264,7 +1299,7 @@ | otherwise = Nothing where sel = flSelector lbl - occ = mkVarOccFS (flLabel lbl) + occ = mkVarOccFS (field_label $ flLabel lbl) mk_user_con_res_ty :: IfaceEqSpec -> SDoc -- See Note [Result type of a data family GADT] @@ -1286,7 +1321,7 @@ -- 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 @@ -1295,7 +1330,7 @@ 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 @@ -1372,16 +1407,20 @@ -- 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, @@ -1480,7 +1519,6 @@ ppr (HsDmdSig str) = text "Strictness:" <+> ppr str ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" - ppr HsLevity = text "Never levity-polymorphic" ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig @@ -1489,17 +1527,15 @@ ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) instance Outputable IfaceUnfolding where - ppr (IfCompulsory e) = text "" <+> parens (ppr e) - ppr (IfCoreUnfold s _ e) = (if s - then text "" - else Outputable.empty) - <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" - <+> ppr (a,uok,bok), - pprParendIfaceExpr e] + ppr (IfCoreUnfold src _ guide e) + = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ] ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) +instance Outputable IfGuidance where + ppr IfNoGuidance = empty + ppr (IfWhen a u b) = angleBrackets (ppr a <> comma <> ppr u <> ppr b) + {- ************************************************************************ * * @@ -1619,8 +1655,8 @@ freeNamesDM _ = emptyNameSet freeNamesIfConDecls :: IfaceConDecls -> NameSet -freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c -freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet @@ -1687,7 +1723,7 @@ = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceNthCo _ co) +freeNamesIfCoercion (IfaceSelCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceLRCo _ co) = freeNamesIfCoercion co @@ -1743,9 +1779,7 @@ freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCoreUnfold _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet @@ -2106,14 +2140,16 @@ instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c + put_ bh (IfDataTyCon False cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfDataTyCon True cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> liftM IfDataTyCon (get bh) - 2 -> liftM IfNewTyCon (get bh) + 1 -> liftM (IfDataTyCon False) (get bh) + 2 -> liftM (IfDataTyCon True) (get bh) + 3 -> liftM IfNewTyCon (get bh) _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" instance Binary IfaceConDecl where @@ -2246,7 +2282,6 @@ put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh HsNoCafRefs = putByte bh 4 - put_ bh HsLevity = putByte bh 5 put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig @@ -2261,48 +2296,49 @@ return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh 4 -> return HsNoCafRefs - 5 -> return HsLevity 6 -> HsCprSig <$> get bh 7 -> HsLFInfo <$> get bh _ -> HsTagSig <$> get bh instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s c e) = do + put_ bh (IfCoreUnfold s c g e) = do putByte bh 0 put_ bh s putUnfoldingCache bh c + put_ bh g put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 + putByte bh 1 put_ bh as put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e get bh = do h <- getByte bh case h of 0 -> do s <- get bh c <- getUnfoldingCache bh + g <- get bh e <- get bh - return (IfCoreUnfold s c e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh + return (IfCoreUnfold s c g e) + _ -> do as <- get bh bs <- get bh return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) +instance Binary IfGuidance where + put_ bh IfNoGuidance = putByte bh 0 + put_ bh (IfWhen a b c ) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoGuidance + _ -> do a <- get bh + b <- get bh + c <- get bh + return (IfWhen a b c) + putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO () putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike , uf_is_work_free = wf, uf_expandable = exp }) = do @@ -2388,9 +2424,12 @@ 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 +2473,9 @@ 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 @@ -2488,7 +2529,7 @@ 1 -> liftM IfaceDataAlt $ get bh _ -> liftM IfaceLitAlt $ get bh -instance Binary IfaceBinding where +instance (Binary r, Binary b) => Binary (IfaceBindingX b r) where put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac get bh = do @@ -2509,6 +2550,38 @@ d <- get bh return (IfLetBndr a b c d) +instance Binary IfaceTopBndrInfo where + put_ bh (IfLclTopBndr lcl ty info dets) = do + putByte bh 0 + put_ bh lcl + put_ bh ty + put_ bh info + put_ bh dets + put_ bh (IfGblTopBndr gbl) = do + putByte bh 1 + put_ bh gbl + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLclTopBndr <$> get bh <*> get bh <*> get bh <*> get bh + 1 -> IfGblTopBndr <$> get bh + _ -> pprPanic "IfaceTopBndrInfo" (intWithCommas tag) + +instance Binary IfaceMaybeRhs where + put_ bh IfUseUnfoldingRhs = putByte bh 0 + put_ bh (IfRhs e) = do + putByte bh 1 + put_ bh e + + get bh = do + b <- getByte bh + case b of + 0 -> return IfUseUnfoldingRhs + 1 -> IfRhs <$> get bh + _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) + + + instance Binary IfaceJoinInfo where put_ bh IfaceNotJoinPoint = putByte bh 0 put_ bh (IfaceJoinPoint ar) = do @@ -2602,7 +2675,7 @@ instance NFData IfaceConDecls where rnf = \case IfAbstractTyCon -> () - IfDataTyCon f1 -> rnf f1 + IfDataTyCon _ f1 -> rnf f1 IfNewTyCon f1 -> rnf f1 instance NFData IfaceConDecl where @@ -2631,22 +2704,20 @@ HsInline p -> p `seq` () -- TODO: seq further? HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () - HsLevity -> () HsCprSig cpr -> cpr `seq` () HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? HsTagSig sig -> sig `seq` () +instance NFData IfGuidance where + rnf = \case + IfNoGuidance -> () + IfWhen a b c -> a `seq` b `seq` c `seq` () + instance NFData IfaceUnfolding where rnf = \case - IfCoreUnfold inlinable cache expr -> - rnf inlinable `seq` cache `seq` rnf expr + IfCoreUnfold src cache guidance expr -> src `seq` cache `seq` rnf guidance `seq` rnf expr + IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache - IfCompulsory expr -> - rnf expr - IfInlineRule arity b1 b2 e -> - rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e - IfDFunUnfold bndrs exprs -> - rnf bndrs `seq` rnf exprs instance NFData IfaceExpr where rnf = \case @@ -2662,17 +2733,25 @@ 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 instance NFData IfaceAlt where rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs -instance NFData IfaceBinding where +instance (NFData b, NFData a) => NFData (IfaceBindingX a b) where rnf = \case IfaceNonRec bndr e -> rnf bndr `seq` rnf e IfaceRec binds -> rnf binds + +instance NFData IfaceTopBndrInfo where + rnf (IfGblTopBndr n) = n `seq` () + rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` () + +instance NFData IfaceMaybeRhs where + rnf IfUseUnfoldingRhs = () + rnf (IfRhs ce) = rnf ce `seq` () instance NFData IfaceLetBndr where rnf (IfLetBndr nm ty id_info join_info) = diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -28,7 +28,7 @@ IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllSpecBndr, - IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..), + IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, @@ -39,8 +39,8 @@ -- Equality testing isIfaceLiftedTypeKind, - -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags - appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + -- Conversion from IfaceAppArgs to IfaceTypes/ForAllTyFlags + appArgsIfaceTypes, appArgsIfaceTypesForAllTyFlags, -- Printing SuppressBndrSig(..), @@ -55,8 +55,7 @@ pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - ppr_fun_arrow, - isIfaceTauType, + isIfaceRhoType, suppressIfaceInvisibles, stripIfaceInvisVars, @@ -64,18 +63,21 @@ mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, - many_ty + many_ty, pprTypeArrow ) where import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon + , constraintKindTyConName , tupleTyConName - , manyDataConTyCon, oneDataConTyCon + , tupleDataConName + , 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 @@ -161,7 +163,7 @@ -- 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 @@ -191,11 +193,11 @@ 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. @@ -219,7 +221,7 @@ = 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 @@ -351,9 +353,13 @@ See Note [The equality types story] in GHC.Builtin.Types.Prim. -} -data IfaceTyConInfo -- Used to guide pretty-printing - -- and to disambiguate D from 'D (they share a name) +data IfaceTyConInfo -- Used only to guide pretty-printing = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + -- A PromotionFlag value of IsPromoted indicates + -- that the type constructor came from a data + -- constructor promoted by -XDataKinds, and thus + -- should be printed as 'D to distinguish it from + -- an existing type constructor D. , ifaceTyConSort :: IfaceTyConSort } deriving (Eq) @@ -384,7 +390,7 @@ | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion + | IfaceSelCo CoSel IfaceCoercion | IfaceLRCo LeftOrRight IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion @@ -411,7 +417,7 @@ %************************************************************************ %* * - Functions over IFaceTypes + Functions over IfaceTypes * * ************************************************************************ -} @@ -419,36 +425,56 @@ 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 -- @@ -473,17 +499,18 @@ (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) @@ -585,7 +612,7 @@ 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) @@ -628,12 +655,12 @@ = 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 @@ -641,17 +668,17 @@ 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 {- @@ -741,7 +768,7 @@ 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.) ************************************************************************ @@ -773,10 +800,10 @@ | 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 ------------------------------------ @@ -818,19 +845,28 @@ 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` + `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, +However, when printing the definition of Type, Constraint or (->) with :info, this would give confusing output: `type (->) = (->)` (#18594). Solution: detect when we are in :info and disable displaying the synonym with the SDoc option sdocPrintTypeAbbreviations. +If you are creating a similar synonym, make sure it is listed in pprIfaceDecl, +see reference to this Note. If there will be a need, in the future we could expose it as a flag --fprint-type-abbreviations or even two separate flags controlling -TYPE 'LiftedRep and FUN 'Many. +-fprint-type-abbreviations or even three separate flags controlling +TYPE 'LiftedRep, CONSTRAINT 'LiftedRep and FUN 'Many. -} -- | Do we want to suppress kind annotations on binders? @@ -857,9 +893,11 @@ 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) @@ -909,37 +947,51 @@ pprPrecIfaceType prec ty = hideNonStandardTypes (ppr_ty prec) ty -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 (pprIfaceType w) +pprTypeArrow :: FunTyFlag -> IfaceMult -> SDoc +pprTypeArrow af mult + = pprArrow (mb_conc, pprPrecIfaceType) af mult + where + mb_conc (IfaceTyConApp tc _) = Just tc + mb_conc _ = Nothing -ppr_sigma :: PprPrec -> IfaceType -> SDoc -ppr_sigma ctxt_prec ty - = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) +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 @@ -948,7 +1000,7 @@ 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) @@ -1055,7 +1107,7 @@ -> 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 @@ -1150,9 +1202,8 @@ -- | 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 @@ -1181,7 +1232,7 @@ 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 @@ -1233,12 +1284,12 @@ -- 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 @@ -1273,11 +1324,13 @@ 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). @@ -1291,8 +1344,8 @@ -- 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 @@ -1307,7 +1360,7 @@ = not (ifTypeIsVarFree kind) tv_has_kind_var _ = False - tv_is_required = isVisibleArgFlag . binderArgFlag + tv_is_required = isVisibleForAllTyFlag . binderFlag {- Note [When to print foralls] @@ -1337,7 +1390,7 @@ 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. @@ -1398,23 +1451,20 @@ Found hole: _ :: Proxy '['True] This would be bad, because the '[' looks like a character literal. + +A similar issue arises if the element is a character literal (#22488) + ghci> type T = '[ 'x' ] + ghci> :kind! T + T :: [Char] + = '['x'] + Solution: in type-level lists and tuples, add a leading space -if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +if the first element is printed with a single quote. -} ------------------- --- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. --- See Note [Printing promoted type constructors] -pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc -pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) - = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of - IsPromoted -> (space <>) - _ -> id -pprSpaceIfPromotedTyCon _ - = id - -- See equivalent function in "GHC.Core.TyCo.Rep" pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print @@ -1423,8 +1473,19 @@ pprIfaceTyList ctxt_prec ty1 ty2 = case gather ty2 of (arg_tys, Nothing) - -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep - (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + -> + sdocWithContext $ \ctx -> + let + items = ty1:arg_tys + eos = isListEmptyOrSingleton items + ticked = promTick (sdocStyle ctx) (PromotedItemListSyntax eos) + (preBracket, postBracket) = + if ticked + then (char '\'', spaceIfSingleQuote) + else (empty, id) + in + preBracket <> brackets (postBracket (fsep + (punctuate comma (map (ppr_ty topPrec) items)))) (arg_tys, Just tl) -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) @@ -1435,7 +1496,7 @@ 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 @@ -1472,20 +1533,25 @@ | 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 @@ -1498,7 +1564,7 @@ | 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 @@ -1608,29 +1674,29 @@ -- 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 pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) +ppr_iface_tc_app :: (PprPrec -> (a, ForAllTyFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ForAllTyFlag)] -> SDoc -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` liftedTypeKindTyConKey - = ppr_kind_type ctxt_prec +ppr_iface_tc_app pp ctxt_prec tc tys = + sdocOption sdocListTuplePuns $ \listTuplePuns -> + if | listTuplePuns, tc `ifaceTyConHasKey` listTyConKey, [ty] <- tys + -> brackets (pp topPrec ty) - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + -> ppr_kind_type ctxt_prec - | [ ty1@(_, Required) - , ty2@(_, Required) ] <- tys - -- Infix, two visible arguments (we know nothing of precedence though). - -- Don't apply this special case if one of the arguments is invisible, - -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). - = pprIfaceInfixApp ctxt_prec (ppr tc) - (pp opPrec ty1) (pp opPrec ty2) + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + | [ ty1@(_, Required), ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + -> pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2) + | otherwise + -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + -- | Pretty-print an unboxed sum type. The sum should be saturated: -- as many visible arguments as the arity of the sum. -- @@ -1657,12 +1723,9 @@ IsPromoted -> let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys - spaceIfPromoted = case args' of - arg0:_ -> pprSpaceIfPromotedTyCon arg0 - _ -> id in ppr_tuple_app args' $ pprPromotionQuoteI IsPromoted <> - tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args')) NotPromoted | ConstraintTuple <- sort @@ -1688,9 +1751,12 @@ -- `Solo x`, not `(x)` | [_] <- args_wo_runtime_reps , BoxedTuple <- sort - = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon - unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in - pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args + = let solo_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon + tupleName = case promoted of + IsPromoted -> tupleDataConName (tupleSortBoxity sort) + NotPromoted -> tupleTyConName sort + solo_tc = IfaceTyCon (tupleName 1) solo_tc_info in + pprPrecIfaceType ctxt_prec $ IfaceTyConApp solo_tc args | otherwise = ppr_args_w_parens @@ -1710,16 +1776,21 @@ 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 topPrec 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 ppr_co ctxt_prec (IfaceAppCo co1 co2) @@ -1765,8 +1836,8 @@ 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) @@ -1808,11 +1879,21 @@ pprPromotionQuote :: IfaceTyCon -> SDoc pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + getPprStyle $ \sty -> + let + name = getOccName (ifaceTyConName tc) + ticked = + case ifaceTyConIsPromoted (ifaceTyConInfo tc) of + NotPromoted -> False + IsPromoted -> promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty pprPromotionQuoteI :: PromotionFlag -> SDoc pprPromotionQuoteI NotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' +pprPromotionQuoteI IsPromoted = char '\'' instance Outputable IfaceCoercion where ppr = pprIfaceCoercion @@ -2056,7 +2137,7 @@ 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 @@ -2093,10 +2174,10 @@ 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 @@ -2127,7 +2208,7 @@ 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 @@ -2213,7 +2294,7 @@ 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/Linker/Static/Utils.hs b/compiler/GHC/Linker/Static/Utils.hs --- a/compiler/GHC/Linker/Static/Utils.hs +++ b/compiler/GHC/Linker/Static/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + module GHC.Linker.Static.Utils where import GHC.Prelude @@ -12,20 +14,18 @@ -- Use the provided filename (if any), otherwise use "main.exe" (Windows), -- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the -- extension if it is missing. -exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath -exeFileName platform staticLink output_fn - | Just s <- output_fn = - case platformOS platform of - OSMinGW32 -> s "exe" - _ -> if staticLink - then s "a" - else s - | otherwise = - if platformOS platform == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" +exeFileName :: ArchOS -> Bool -> Maybe FilePath -> FilePath +exeFileName (ArchOS arch os) staticLink output_fn + | Just s <- output_fn = if + | OSMinGW32 <- os -> s "exe" + | ArchJavaScript <- arch -> s "jsexe" + | ArchWasm32 <- arch -> s "wasm" + | staticLink -> s "a" + | otherwise -> s + | otherwise = if + | OSMinGW32 <- os -> "main.exe" + | ArchJavaScript <- arch -> "main.jsexe" + | staticLink -> "liba.a" + | otherwise -> "a.out" where s ext | null (takeExtension s) = s <.> ext | otherwise = s - diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -5,7 +5,7 @@ -- (c) The University of Glasgow 2019 -- ----------------------------------------------------------------------------- - +{-# LANGUAGE TypeApplications #-} module GHC.Linker.Types ( Loader (..) , LoaderState (..) @@ -55,6 +55,7 @@ import GHC.Unit.Module.Env import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Unit.Module.WholeCoreBindings {- ********************************************************************** @@ -107,7 +108,7 @@ in pls { linker_env = le { closure_env = f ce } } data LinkerEnv = LinkerEnv - { closure_env :: !ClosureEnv + { closure_env :: ClosureEnv -- ^ Current global mapping from closure Names to their true values , itbl_env :: !ItblEnv @@ -192,6 +193,10 @@ = DotO ObjFile -- ^ An object file (.o) | DotA FilePath -- ^ Static archive file (.a) | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend + -- See Note [Interface Files with Core Definitions] + | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid + -- being too strict. | BCOs CompiledByteCode [SptEntry] -- ^ A byte-code object, lives only in memory. Also -- carries some static pointer table entries which @@ -204,6 +209,8 @@ ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + ppr (LoadedBCOs{}) = text "LoadedBCOs" + ppr (CoreBindings {}) = text "FI" -- | An entry to be inserted into a module's static pointer table. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". @@ -241,6 +248,8 @@ nameOfObject_maybe (DotO fn) = Just fn nameOfObject_maybe (DotA fn) = Just fn nameOfObject_maybe (DotDLL fn) = Just fn +nameOfObject_maybe (CoreBindings {}) = Nothing +nameOfObject_maybe (LoadedBCOs{}) = Nothing nameOfObject_maybe (BCOs {}) = Nothing -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object @@ -248,8 +257,9 @@ nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject :: Unlinked -> [CompiledByteCode] +byteCodeOfObject (BCOs bc _) = [bc] +byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) {- ********************************************************************** @@ -280,7 +290,7 @@ | Framework String -- Only used for darwin, but does no harm instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Objects objs) = text "Objects" <+> ppr (map (text @SDoc) objs) ppr (Archive a) = text "Archive" <+> text a ppr (DLL s) = text "DLL" <+> text s ppr (DLLPath f) = text "DLLPath" <+> text f diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API. @@ -66,7 +67,7 @@ import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error ( GhcHint(..) ) @@ -76,7 +77,7 @@ 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 ) @@ -91,8 +92,11 @@ 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(..)) + import qualified Data.Semigroup as Semi } @@ -460,7 +464,7 @@ foo :: (:%) Ambiguity: - If we reduced, (:%) would be parsed as a parenthehsized infix type + If we reduced, (:%) would be parsed as a parenthesized infix type expression without arguments, resulting in the 'failOpFewArgs' error. We shift, so it is parsed as a type constructor. @@ -702,7 +706,7 @@ MDO { L _ (ITmdo _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension - LABELVARID { L _ (ITlabelvarid _) } + LABELVARID { L _ (ITlabelvarid _ _) } CHAR { L _ (ITchar _ _) } STRING { L _ (ITstring _ _) } @@ -821,7 +825,7 @@ litpkgname :: { Located FastString } : litpkgname_segment { $1 } -- a bit of a hack, means p - b is parsed same as p-b, enough for now. - | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } + | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] } mayberns :: { Maybe [LRenaming] } : {- empty -} { Nothing } @@ -853,12 +857,12 @@ NotBoot -> HsSrcFile IsBoot -> HsBootFile) (reLoc $3) - (sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) } + (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) } | 'signature' modid maybemodwarning maybeexports 'where' body { sL1 $1 $ DeclD HsigFile (reLoc $2) - (sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) } + (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) } | 'dependency' unitid mayberns { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 , idModRenaming = $3 @@ -878,26 +882,32 @@ -- either, and DEPRECATED is only expected to be used by people who really -- know what they are doing. :-) -signature :: { Located HsModule } +signature :: { Located (HsModule GhcPs) } : 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - acs (\cs-> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs) - (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) - (snd $ sndOf3 $6) $3 Nothing)) + acs (\cs-> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs) + (thdOf3 $6) $3 Nothing) + (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6))) ) } -module :: { Located HsModule } +module :: { Located (HsModule GhcPs) } : 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs) - (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) - (snd $ sndOf3 $6) $3 Nothing) + acsFinal (\cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs) + (thdOf3 $6) $3 Nothing) + (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6)) )) } | body2 {% fileSrcSpan >>= \ loc -> - acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs) - (thdOf3 $1) Nothing Nothing - (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) } + acsFinal (\cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs) + (thdOf3 $1) Nothing Nothing) + Nothing Nothing + (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext } @@ -916,17 +926,17 @@ body :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo) } + ,LayoutInfo GhcPs) } : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) - , snd $2, ExplicitBraces) } + , snd $2, explicitBraces $1 $3) } | vocurly top close { (AnnList Nothing Nothing Nothing [] (fst $2) , snd $2, VirtualBraces (getVOCURLY $1)) } body2 :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo) } + ,LayoutInfo GhcPs) } : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) - , snd $2, ExplicitBraces) } + , snd $2, explicitBraces $1 $3) } | missing_module_keyword top close { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) } @@ -942,21 +952,24 @@ ----------------------------------------------------------------------------- -- Module declaration & imports only -header :: { Located HsModule } +header :: { Located (HsModule GhcPs) } : 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) - NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + acs (\cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) + NoLayoutInfo $3 Nothing) + (Just $2) $4 $6 [] ))) } | 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) - NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + acs (\cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) + NoLayoutInfo $3 Nothing) + (Just $2) $4 $6 [] ))) } | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing - Nothing)) } + return (L loc (HsModule (XModulePs noAnn NoLayoutInfo Nothing Nothing) Nothing Nothing $1 [])) } header_body :: { [LImportDecl GhcPs] } : '{' header_top { $2 } @@ -1101,14 +1114,12 @@ , importDeclAnnAs = fst $8 } ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $ - ImportDecl { ideclExt = EpAnn (glR $1) anns cs - , ideclSourceSrc = snd $ fst $2 + ImportDecl { ideclExt = XImportDeclPass (EpAnn (glR $1) anns cs) (snd $ fst $2) False , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual - , ideclImplicit = False , ideclAs = unLoc (snd $8) - , ideclHiding = unLoc $9 }) + , ideclImportList = unLoc $9 }) } } @@ -1139,20 +1150,20 @@ ,sLL $1 (reLoc $>) (Just $2)) } | {- empty -} { (Nothing,noLoc Nothing) } -maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) } +maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, LocatedL [LIE GhcPs]) } +impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) } : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2) (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) - ; return $ sLL $1 $> (False, es)} } + ; return $ sLL $1 $> (Exactly, es)} } | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3) (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) []) - ; return $ sLL $1 $> (True, es)} } + ; return $ sLL $1 $> (EverythingBut, es)} } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -1215,9 +1226,9 @@ | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $> (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) } | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) } - | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) } - | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) } - | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (EpAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) } + | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) } + | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) } + | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) } | annotation { $1 } | decl_no_th { $1 } @@ -1261,22 +1272,22 @@ ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } -- ordinary data type or newtype declaration - | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings + {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3 Nothing (reverse (snd $ unLoc $4)) (fmap reverse $5) - ((fst $ unLoc $1):(fst $ unLoc $4)) } + ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist maybe_derivings - {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3 (snd $ unLoc $4) (snd $ unLoc $5) (fmap reverse $6) - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } + ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -1500,6 +1511,11 @@ (fmap reverse $7) ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) } +type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) } + : 'data' { sL1 $1 ([mj AnnData $1], False,DataType) } + | 'newtype' { sL1 $1 ([mj AnnNewtype $1], False,NewType) } + | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) } + data_or_newtype :: { Located (AddEpAnn, NewOrData) } : 'data' { sL1 $1 (mj AnnData $1,DataType) } | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } @@ -1651,7 +1667,7 @@ : 'pattern' con_list '::' sigtype {% acsA (\cs -> sLL $1 (reLoc $>) $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs) - (unLoc $2) $4) } + (toList $ unLoc $2) $4) } qvarcon :: { LocatedN RdrName } : qvar { $1 } @@ -1697,9 +1713,9 @@ decllist_cls :: { Located ([AddEpAnn] , OrdList (LHsDecl GhcPs) - , LayoutInfo) } -- Reversed + , LayoutInfo GhcPs) } -- Reversed : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2, ExplicitBraces) } + ,snd $ unLoc $2, explicitBraces $1 $3) } | vocurly decls_cls close { let { L l (anns, decls) = $2 } in L l (anns, decls, VirtualBraces (getVOCURLY $1)) } @@ -1707,7 +1723,7 @@ -- where_cls :: { Located ([AddEpAnn] ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo) } + ,LayoutInfo GhcPs) } -- No implicit parameters -- May have type declarations : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2) @@ -1833,8 +1849,8 @@ {%runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> acsA (\cs -> (sLLlA $1 $> $ HsRule - { rd_ext = EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs - , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRINGs $1, getSTRING $1) + { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1) + , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 })) } @@ -1991,20 +2007,20 @@ annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs) - (getANN_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs), + (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs) - (getANN_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs), + (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs) - (getANN_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs), + (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } ----------------------------------------------------------------------------- @@ -2371,7 +2387,7 @@ -- Returns a list because of: C,D :: ty -- TODO:AZ capture the optSemi. Why leading? : optSemi con_list '::' sigtype - {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] } + {% mkGadtDecl (comb2A $2 $>) (unLoc $2) (hsUniTok $3) $4 } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2418,7 +2434,7 @@ | {- empty -} { noLoc ([], Nothing) } constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) } - : infixtype {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b, + : infixtype {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b, dataConBuilderDetails b)))) (runPV $1) } @@ -2573,7 +2589,7 @@ {% let (dcolon, tc) = $3 in acsA (\cs -> sLL $1 $> - (SigD noExtField (CompleteMatchSig (EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) } + (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvarcon '#-}' @@ -2584,12 +2600,12 @@ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2 (mkOpaquePragma (getOPAQUE_PRAGs $1))))) } | '{-# SCC' qvar '#-}' - {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) } + {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing - ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1a $3 str_lit))))) }} + ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }} | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% acsA (\cs -> @@ -2604,11 +2620,11 @@ | '{-# SPECIALISE' 'instance' inst_type '#-}' {% acsA (\cs -> sLL $1 $> - $ SigD noExtField (SpecInstSig (EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) } + $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (EpAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) } + {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) } activation :: { ([AddEpAnn],Maybe Activation) } -- See Note [%shift: activation -> {- empty -}] @@ -2625,15 +2641,15 @@ ----------------------------------------------------------------------------- -- Expressions -quasiquote :: { Located (HsSplice GhcPs) } +quasiquote :: { Located (HsUntypedSplice GhcPs) } : TH_QUASIQUOTE { let { loc = getLoc $1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } - in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } + in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) } | TH_QQUASIQUOTE { let { loc = getLoc $1 ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkQual varName (qual, quoter) } - in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } + in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) } exp :: { ECP } : infixexp '::' ctype @@ -2750,13 +2766,13 @@ : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 ; acs (\cs -> (sLL $1 $> (HsPragSCC - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs) - (getSCC_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs), + (getSCC_PRAGs $1)) (StringLiteral (getSTRINGs $2) scc Nothing))))} } | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $> (HsPragSCC - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs) - (getSCC_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs), + (getSCC_PRAGs $1)) (StringLiteral NoSourceText (getVARID $2) Nothing)))) } fexp :: { ECP } @@ -2769,7 +2785,7 @@ -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | fexp PREFIX_AT atype { ECP $ unECP $1 >>= \ $1 -> - mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 } + mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (hsTok $2) $3 } | 'static' aexp {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ @@ -2782,7 +2798,7 @@ : qvar TIGHT_INFIX_AT aexp { ECP $ unECP $3 >>= \ $3 -> - mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] } + mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 (hsTok $2) $3 } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer @@ -2874,8 +2890,8 @@ | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> fmap ecpFromExp $ acsa (\cs -> - let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) (reLocA $3)) in - mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) } + let fl = sLLa $2 (reLoc $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in + mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) } | aexp2 { $1 } @@ -2885,7 +2901,7 @@ | qcon { ECP $ mkHsVarPV $! $1 } -- See Note [%shift: aexp2 -> ipvar] | ipvar %shift {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) } - | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) } + | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) } | literal { ECP $ pvA (mkHsLitPV $! $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -XOverloadedStrings is on. @@ -2926,7 +2942,7 @@ -- Template Haskell Extension | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 } - | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) } + | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) } | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } @@ -2960,23 +2976,23 @@ projection -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer : projection TIGHT_INFIX_PROJ field - {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) `NE.cons` unLoc $1)) } - | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)) :| [])) } + {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) } + | PREFIX_PROJ field {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) } splice_exp :: { LHsExpr GhcPs } - : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) } - | splice_typed { mapLoc (HsSpliceE noAnn) (reLocA $1) } + : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) } + | splice_typed { fmap (uncurry HsTypedSplice) (reLocA $1) } -splice_untyped :: { Located (HsSplice GhcPs) } +splice_untyped :: { Located (HsUntypedSplice GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - acs (\cs -> sLLlA $1 $> $ mkUntypedSplice (EpAnn (glR $1) [mj AnnDollar $1] cs) DollarSplice $2) } + acs (\cs -> sLLlA $1 $> $ HsUntypedSpliceExpr (EpAnn (glR $1) [mj AnnDollar $1] cs) $2) } -splice_typed :: { Located (HsSplice GhcPs) } +splice_typed :: { Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - acs (\cs -> sLLlA $1 $> $ mkTypedSplice (EpAnn (glR $1) [mj AnnDollarDollar $1] cs) DollarSplice $2) } + acs (\cs -> sLLlA $1 $> $ ((noAnn, EpAnn (glR $1) [mj AnnDollarDollar $1] cs), $2)) } cmdargs :: { [LHsCmdTop GhcPs] } : cmdargs acmd { $2 : $1 } @@ -3042,34 +3058,34 @@ : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)] + do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)] ; return (Tuple (Right t : snd $2)) } } | commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) } + do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst $1) } ; return (Tuple (cos ++ $2)) } } | texp bars { unECP $1 >>= \ $1 -> return $ - (Sum 1 (snd $2 + 1) $1 [] (map (EpaSpan . realSrcSpan) $ fst $2)) } + (Sum 1 (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) } | bars texp bars0 { unECP $2 >>= \ $2 -> return $ (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 - (map (EpaSpan . realSrcSpan) $ fst $1) - (map (EpaSpan . realSrcSpan) $ fst $3)) } + (map srcSpan2e $ fst $1) + (map srcSpan2e $ fst $3)) } -- Always starts with commas; always follows an expr commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) } commas_tup_tail : commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) } + do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst $1) } ; return ((head $ fst $1, cos ++ $2)) } } -- Always follows a comma tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] } : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)] + do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)] ; return (Right t : snd $2) } } | texp { unECP $1 >>= \ $1 -> return [Right $1] } @@ -3318,10 +3334,10 @@ -- Statement sequences stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) } - : '{' stmts '}' { $2 >>= \ $2 -> amsrl - (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) } + : '{' stmts '}' { $2 >>= \ $2 -> + amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) } | vocurly stmts close { $2 >>= \ $2 -> amsrl - (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) } + (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3409,15 +3425,15 @@ -- AZ: need to pull out the let block into a helper | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp { do - let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1) + let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (reLoc $ L lf ()) fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields - l = comb2 $1 $3 + l = comb2 (reLoc $1) $3 isPun = False $5 <- unECP $5 - fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun + fmap Right $ mkHsProjUpdatePV (comb2 (reLoc $1) (reLoc $5)) (L l fields) $5 isPun [mj AnnEqual $4] } @@ -3425,24 +3441,24 @@ -- AZ: need to pull out the let block into a helper | field TIGHT_INFIX_PROJ fieldToUpdate { do - let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1) + let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (reLoc $ L lf ()) fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields - l = comb2 $1 $3 + l = comb2 (reLoc $1) $3 isPun = True - var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final)) + var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final)) fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] } fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] } fieldToUpdate -- See Note [Whitespace-sensitive operator parsing] in Lexer.x - : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLoc $3) >>= \cs -> - return (sLL $1 $> ((sLLa $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) (reLocA $3))) : unLoc $1)) } - | field {% getCommentsFor (getLoc $1) >>= \cs -> - return (sL1 $1 [sL1a $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) (reLocA $1))]) } + : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLocA $3) >>= \cs -> + return (sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) } + | field {% getCommentsFor (getLocA $1) >>= \cs -> + return (sL1 (reLoc $1) [sL1a (reLoc $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -3471,8 +3487,8 @@ ----------------------------------------------------------------------------- -- Overloaded labels -overloaded_label :: { Located FastString } - : LABELVARID { sL1 $1 (getLABELVARID $1) } +overloaded_label :: { Located (SourceText, FastString) } + : LABELVARID { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) } ----------------------------------------------------------------------------- -- Warnings and deprecations @@ -3535,10 +3551,9 @@ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -con_list :: { Located [LocatedN RdrName] } -con_list : con { sL1N $1 [$1] } - | con ',' con_list {% do { h <- addTrailingCommaN $1 (gl $2) - ; return (sLL (reLocN $1) $> (h : unLoc $3)) }} +con_list :: { Located (NonEmpty (LocatedN RdrName)) } +con_list : con { sL1N $1 (pure $1) } + | con ',' con_list {% sLL (reLocN $1) $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) } qcon_list :: { Located [LocatedN RdrName] } qcon_list : qcon { sL1N $1 [$1] } @@ -3549,10 +3564,10 @@ sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors : '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } | '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) - (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } | '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } | '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) - (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } -- See Note [Empty lists] in GHC.Hs.Expr sysdcon :: { LocatedN DataCon } @@ -3586,12 +3601,12 @@ : oqtycon { $1 } | '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed (snd $2 + 1))) - (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } | '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) - (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } | '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1))) - (NameAnnBars NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR) @@ -3744,8 +3759,8 @@ -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. -field :: { Located FastString } - : varid { reLocN $ fmap (occNameFS . rdrNameOcc) $1 } +field :: { LocatedN FieldLabelString } + : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 } qvarid :: { LocatedN RdrName } : varid { $1 } @@ -3816,7 +3831,7 @@ special_sym :: { Located FastString } special_sym : '.' { sL1 $1 (fsLit ".") } - | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) } + | '*' { sL1 $1 (starSym (isUnicode $1)) } ----------------------------------------------------------------------------- -- Data constructors @@ -3871,8 +3886,7 @@ : CONID { sL1a $1 $ mkModuleNameFS (getCONID $1) } | QCONID { sL1a $1 $ let (mod,c) = getQCONID $1 in mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) + (concatFS [mod, fsLit ".", c]) } commas :: { ([SrcSpan],Int) } -- One or more commas @@ -3902,7 +3916,7 @@ getQVARSYM (L _ (ITqvarsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid x)) = x +getLABELVARID (L _ (ITlabelvarid _ x)) = x getCHAR (L _ (ITchar _ x)) = x getSTRING (L _ (ITstring _ x)) = x getINTEGER (L _ (ITinteger x)) = x @@ -3927,6 +3941,8 @@ getPRIMINTEGERs (L _ (ITprimint src _)) = src getPRIMWORDs (L _ (ITprimword src _)) = src +getLABELVARIDs (L _ (ITlabelvarid src _)) = src + -- See Note [Pragma source text] in "GHC.Types.Basic" for the following getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl getOPAQUE_PRAGs (L _ (ITopaque_prag src)) = src @@ -4196,27 +4212,27 @@ -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself mj :: AnnKeywordId -> Located e -> AddEpAnn -mj a l = AddEpAnn a (EpaSpan $ rs $ gl l) +mj a l = AddEpAnn a (srcSpan2e $ gl l) mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn -mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l) +mjN a l = AddEpAnn a (srcSpan2e $ glN l) -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself, provided the span is not zero width mz :: AnnKeywordId -> Located e -> [AddEpAnn] -mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)] +mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)] msemi :: Located e -> [TrailingAnn] -msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)] +msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)] msemim :: Located e -> Maybe EpaLocation -msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l) +msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l) -- |Construct an AddEpAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddEpAnn -mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l) +mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation @@ -4239,7 +4255,7 @@ glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor glAA :: Located a -> EpaLocation -glAA = EpaSpan <$> realSrcSpan . getLoc +glAA = srcSpan2e . getLoc glRR :: Located a -> RealSrcSpan glRR = realSrcSpan . getLoc @@ -4251,7 +4267,7 @@ glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor glNRR :: LocatedN a -> EpaLocation -glNRR = EpaSpan <$> realSrcSpan . getLocA +glNRR = srcSpan2e . getLocA anc :: RealSrcSpan -> Anchor anc r = Anchor r UnchangedAnchor @@ -4361,7 +4377,7 @@ -- This is the only parser entry point that deals with Haddock comments. -- The other entry points ('parseDeclaration', 'parseExpression', etc) do -- not insert them into the AST. -parseModule :: P (Located HsModule) +parseModule :: P (Located (HsModule GhcPs)) parseModule = parseModuleNoHaddock >>= addHaddockToModule commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) @@ -4381,7 +4397,7 @@ hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList hsDoAnn (L l _) (L ll _) kw - = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] [] + = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] [] listAsAnchor :: [LocatedAn t a] -> Anchor listAsAnchor [] = spanAsAnchor noSrcSpan @@ -4395,6 +4411,9 @@ L (mkTokenLocation l) (if isUnicode t then HsUnicodeTok else HsNormalTok) +explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs +explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2) + -- ------------------------------------- addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b) @@ -4418,16 +4437,16 @@ let anns' = if isZeroWidthSpan ss then anns - else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns + else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns return (L (SrcSpanAnn anns' l) a) -- ------------------------------------- addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span)) +addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span)) addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span)) +addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span)) addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do @@ -4445,7 +4464,7 @@ -- AZ:TODO: generalise updating comments into an annotation let anns' = if isZeroWidthSpan span then anns - else addTrailingCommaToN l anns (EpaSpan $ rs span) + else addTrailingCommaToN l anns (srcSpan2e span) return (L (SrcSpanAnn anns' l) a) addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -51,7 +51,7 @@ la2na, na2la, n2l, l2n, l2l, la2la, reLoc, reLocA, reLocL, reLocC, reLocN, - la2r, realSrcSpan, + srcSpan2e, la2e, realSrcSpan, -- ** Building up annotations extraToAnnList, reAnn, @@ -95,7 +95,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString -import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -202,7 +201,6 @@ data AnnKeywordId = AnnAnyclass | AnnAs - | AnnAt | AnnBang -- ^ '!' | AnnBackquote -- ^ '`' | AnnBy @@ -405,7 +403,7 @@ -- in the @'EpaDelta'@ variant captures any comments between the prior -- output and the thing being marked here, since we cannot otherwise -- sort the relative order. -data EpaLocation = EpaSpan !RealSrcSpan +data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) | EpaDelta !DeltaPos ![LEpaComment] deriving (Data,Eq) @@ -414,6 +412,9 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation deriving (Data,Eq) +instance Outputable a => Outputable (GenLocated TokenLocation a) where + ppr (L _ x) = ppr x + -- | Spacing between output items when exact printing. It captures -- the spacing from the current print position on the page to the -- position required for the thing about to be printed. This is @@ -446,15 +447,15 @@ -- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the -- partial function is safe. epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan -epaLocationRealSrcSpan (EpaSpan r) = r +epaLocationRealSrcSpan (EpaSpan r _) = r epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation -epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) -epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) +epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing +epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing instance Outputable EpaLocation where - ppr (EpaSpan r) = text "EpaSpan" <+> ppr r + ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs instance Outputable AddEpAnn where @@ -545,7 +546,7 @@ -- element, and print them together with the element, interleaving -- them into the output stream. But when editing the AST to move -- fragments around it is useful to be able to first separate the --- comments into those occuring before the AST element and those +-- comments into those occurring before the AST element and those -- following it. The 'EpaCommentsBalanced' constructor is used to do -- this. The GHC parser will only insert the 'EpaComments' form. data EpAnnComments = EpaComments @@ -631,7 +632,7 @@ -- Annotations for items in a list -- --------------------------------------------------------------------- --- | Captures the location of punctuation occuring between items, +-- | Captures the location of punctuation occurring between items, -- normally in a list. It is captured as a trailing annotation. data TrailingAnn = AddSemiAnn EpaLocation -- ^ Trailing ';' @@ -915,9 +916,13 @@ where l = mkRealSrcLoc (fsLit "foo") (-1) (-1) -la2r :: SrcSpanAnn' a -> RealSrcSpan -la2r l = realSrcSpan (locA l) +srcSpan2e :: SrcSpan -> EpaLocation +srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb +srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing +la2e :: SrcSpanAnn' a -> EpaLocation +la2e = srcSpan2e . locA + extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t @@ -975,7 +980,7 @@ widenSpan s as = foldl combineSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest + go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest go (AddEpAnn _ (EpaDelta _ _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure @@ -984,7 +989,7 @@ widenRealSpan s as = foldl combineRealSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s):rest) = s : go rest + go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest go (AddEpAnn _ (EpaDelta _ _):rest) = go rest widenAnchor :: Anchor -> [AddEpAnn] -> Anchor @@ -1246,17 +1251,6 @@ instance Outputable IsUnicodeSyntax where ppr = text . show - -instance Binary a => Binary (LocatedL a) where - -- We do not serialise the annotations - put_ bh (L l x) = do - put_ bh (locA l) - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L (noAnnSrcSpan l) x) instance (Outputable a) => Outputable (SrcSpanAnn' a) where ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -3,6 +3,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -18,6 +22,7 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable @@ -26,16 +31,18 @@ import GHC.Data.Maybe (catMaybes) import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword) import GHC.Hs.Type (pprLHsContext) -import GHC.Builtin.Names (allNameStrings) +import GHC.Builtin.Names (allNameStringList) import GHC.Builtin.Types (filterCTuple) import qualified GHC.LanguageExtensions as LangExt import Data.List.NonEmpty (NonEmpty((:|))) instance Diagnostic PsMessage where - diagnosticMessage = \case - PsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts PsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + PsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m PsHeaderMessage m -> psHeaderMessageDiagnostic m @@ -70,20 +77,20 @@ PsWarnTransitionalLayout reason -> mkSimpleDecorated $ text "transitional layout will not be accepted in the future:" - $$ text (case reason of - TransLayout_Where -> "`where' clause at the same depth as implicit layout block" - TransLayout_Pipe -> "`|' at the same depth as implicit layout block" + $$ (case reason of + TransLayout_Where -> text "`where' clause at the same depth as implicit layout block" + TransLayout_Pipe -> text "`|' at the same depth as implicit layout block" ) PsWarnOperatorWhitespaceExtConflict sym -> let mk_prefix_msg extension_name syntax_meaning = text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym) - <+> text "would denote" <+> text syntax_meaning - $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.") + <+> text "would denote" <+> syntax_meaning + $$ nest 2 (text "were the" <+> extension_name <+> text "extension enabled.") in mkSimpleDecorated $ case sym of - OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation" - OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice" - OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice" + OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg (text "LinearTypes") (text "a multiplicity annotation") + OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg (text "TemplateHaskell") (text "an untyped splice") + OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg (text "TemplateHaskell") (text "a typed splice") PsWarnOperatorWhitespace sym occ_type -> let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) @@ -105,8 +112,9 @@ <+> quotes (text "Data.Kind.Type") $$ text "relies on the StarIsType extension, which will become" $$ text "deprecated in the future." - PsWarnUnrecognisedPragma + PsWarnUnrecognisedPragma prag _ -> mkSimpleDecorated $ text "Unrecognised pragma" + <> if null prag then empty else text ":" <+> text prag PsWarnMisplacedPragma prag -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma" PsWarnImportPreQualified @@ -116,21 +124,21 @@ PsErrLexer err kind -> mkSimpleDecorated $ hcat - [ text $ case err of - LexError -> "lexical error" - LexUnknownPragma -> "unknown pragma" - LexErrorInPragma -> "lexical error in pragma" - LexNumEscapeRange -> "numeric escape sequence out of range" - LexStringCharLit -> "lexical error in string/character literal" - LexStringCharLitEOF -> "unexpected end-of-file in string/character literal" - LexUnterminatedComment -> "unterminated `{-'" - LexUnterminatedOptions -> "unterminated OPTIONS pragma" - LexUnterminatedQQ -> "unterminated quasiquotation" + [ case err of + LexError -> text "lexical error" + LexUnknownPragma -> text "unknown pragma" + LexErrorInPragma -> text "lexical error in pragma" + LexNumEscapeRange -> text "numeric escape sequence out of range" + LexStringCharLit -> text "lexical error in string/character literal" + LexStringCharLitEOF -> text "unexpected end-of-file in string/character literal" + LexUnterminatedComment -> text "unterminated `{-'" + LexUnterminatedOptions -> text "unterminated OPTIONS pragma" + LexUnterminatedQQ -> text "unterminated quasiquotation" - , text $ case kind of - LexErrKind_EOF -> " at end of input" - LexErrKind_UTF8 -> " (UTF-8 decoding error)" - LexErrKind_Char c -> " at character " ++ show c + , case kind of + LexErrKind_EOF -> text " at end of input" + LexErrKind_UTF8 -> text " (UTF-8 decoding error)" + LexErrKind_Char c -> text $ " at character " ++ show c ] PsErrParse token _details | null token @@ -445,7 +453,7 @@ PEIP_NegApp -> text "-" <> ppr s PEIP_TypeArgs peipd_tyargs | not (null peipd_tyargs) -> ppr s <+> vcat [ - hsep [text "@" <> ppr t | t <- peipd_tyargs] + hsep (map ppr peipd_tyargs) , text "Type applications in patterns are only allowed on data constructors." ] | otherwise -> ppr s @@ -478,7 +486,7 @@ , nest 2 (what <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) + <+> hsep (map text (takeList tparms allNameStringList)) <+> equals_or_where) ] ] where -- Avoid printing a constraint tuple in the error message. Print @@ -499,7 +507,23 @@ ] PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] - diagnosticReason = \case + PsErrMultipleConForNewtype tycon n -> mkSimpleDecorated $ vcat + [ sep + [ text "A newtype must have exactly one constructor," + , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + , text "In the newtype declaration for" <+> quotes (ppr tycon) ] + + PsErrUnicodeCharLooksLike bad_char looks_like_char looks_like_char_name + -> mkSimpleDecorated $ + hsep [ text "Unicode character" + -- purposefully not using `quotes (text [bad_char])`, because the quotes function adds smart quotes, + -- and smart quotes may be the topic of this error message + , text "'" <> text [bad_char] <> text "' (" <> text (show bad_char) <> text ")" + , text "looks like" + , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma + , text "but it is not" ] + + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters @@ -511,7 +535,7 @@ PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType - PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas + PsWarnUnrecognisedPragma{} -> WarningWithFlag Opt_WarnUnrecognisedPragmas PsWarnMisplacedPragma{} -> WarningWithFlag Opt_WarnMisplacedPragmas PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule PsErrLexer{} -> ErrorWithoutFlag @@ -615,8 +639,10 @@ PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag PsErrInvalidCApiImport {} -> ErrorWithoutFlag + PsErrMultipleConForNewtype {} -> ErrorWithoutFlag + PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag - diagnosticHints = \case + diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m PsHeaderMessage m -> psHeaderMessageHints m PsWarnBidirectionalFormatChars{} -> noHints @@ -628,7 +654,12 @@ PsWarnHaddockIgnoreMulti -> noHints PsWarnStarBinder -> [SuggestQualifyStarOperator] PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing] - PsWarnUnrecognisedPragma -> noHints + PsWarnUnrecognisedPragma "" _ -> noHints + PsWarnUnrecognisedPragma p avail -> + let suggestions = fuzzyMatch p avail + in if null suggestions + then noHints + else [SuggestCorrectPragmaName suggestions] PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] @@ -779,6 +810,10 @@ PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints PsErrInvalidCApiImport {} -> noHints + PsErrMultipleConForNewtype {} -> noHints + PsErrUnicodeCharLooksLike{} -> noHints + + diagnosticCode = constructorCode psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module GHC.Parser.Errors.Types where import GHC.Prelude -import Data.Typeable - import GHC.Core.TyCon (Role) import GHC.Data.FastString import GHC.Hs @@ -15,11 +14,11 @@ import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader -import GHC.Unit.Module.Name -import GHC.Utils.Outputable import Data.List.NonEmpty (NonEmpty) import GHC.Types.SrcLoc (PsLoc) +import GHC.Generics ( Generic ) + -- The type aliases below are useful to make some type signatures a bit more -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. @@ -60,6 +59,7 @@ tests/driver/T2499 -} | PsErrUnknownOptionsPragma !String + deriving Generic data PsMessage @@ -68,7 +68,7 @@ arbitrary messages to be embedded. The typical use case would be GHC plugins willing to emit custom diagnostics. -} - forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a + PsUnknownMessage UnknownDiagnostic {-| A group of parser messages emitted in 'GHC.Parser.Header'. See Note [Messages from GHC.Parser.Header]. @@ -78,7 +78,7 @@ {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag) that occurs when unicode bi-directional format characters are found within in a file - The 'PsLoc' contains the exact position in the buffer the character occured, and the + The 'PsLoc' contains the exact position in the buffer the character occurred, and the string contains a description of the character. -} | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String)) @@ -117,8 +117,9 @@ -} | PsWarnTransitionalLayout !TransLayoutReason - -- | Unrecognised pragma - | PsWarnUnrecognisedPragma + -- | Unrecognised pragma. First field is the actual pragma name which + -- might be empty. Second field is the set of valid candidate pragmas. + | PsWarnUnrecognisedPragma !String ![String] | PsWarnMisplacedPragma !FileHeaderPragmaType -- | Invalid Haddock comment position @@ -456,13 +457,22 @@ -- | Parse error in right operator section pattern -- TODO: embed the proper operator, if possible - | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs) + | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) -- | Illegal linear arrow or multiplicity annotation in GADT record syntax | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) | PsErrInvalidCApiImport + | PsErrMultipleConForNewtype !RdrName !Int + + | PsErrUnicodeCharLooksLike + Char -- ^ the problematic character + Char -- ^ the character it looks like + String -- ^ the name of the character that it looks like + + deriving Generic + -- | Extra details about a parse error, which helps -- us in determining which should be the hints to -- suggest. @@ -496,7 +506,7 @@ = ParseContext { is_infix :: !(Maybe RdrName) -- ^ If 'Just', this is an infix - -- pattern with the binded operator name + -- pattern with the bound operator name , incomplete_do_block :: !PatIncompleteDoBlock -- ^ Did the parser likely fail due to an incomplete do block? } deriving Eq @@ -504,7 +514,7 @@ data PsErrInPatDetails = PEIP_NegApp -- ^ Negative application pattern? - | PEIP_TypeArgs [HsPatSigType GhcPs] + | PEIP_TypeArgs [HsConPatTyArg GhcPs] -- ^ The list of type arguments for the pattern | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments !PatIsRecursive -- ^ Is the parsed pattern recursive? diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x --- a/compiler/GHC/Parser/HaddockLex.x +++ b/compiler/GHC/Parser/HaddockLex.x @@ -148,7 +148,7 @@ RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] - fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + fakeLoc = mkRealSrcLoc nilFS 0 0 -- | Lex identifiers from a docstring. lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser @@ -169,7 +169,7 @@ plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason - fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + fakeLoc = mkRealSrcLoc nilFS 0 0 validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) validateIdentWith identParser mloc str0 = @@ -191,7 +191,7 @@ buffer = stringBufferFromByteString str0 realSrcLc = case mloc of RealSrcSpan loc _ -> realSrcSpanStart loc - UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0 + UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -145,16 +145,18 @@ loc' = noAnnSrcSpan loc preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc' $ ImportDecl { ideclExt = noAnn, - ideclSourceSrc = NoSourceText, + = L loc' $ ImportDecl { ideclExt = XImportDeclPass + { ideclAnn = noAnn + , ideclSourceText = NoSourceText + , ideclImplicit = True -- Implicit! + }, ideclName = L loc' pRELUDE_NAME, ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, -- Not a safe import ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! ideclAs = Nothing, - ideclHiding = Nothing } + ideclImportList = Nothing } -------------------------------------------------------------- -- Get options diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -273,6 +273,9 @@ "-- " / { atEOL } { lineCommentToken } +-- Everywhere: check for smart quotes--they are not allowed outside of strings +$unigraphic / { isSmartQuote } { smart_quote_error } + -- 'bol' state: beginning of a line. Slurp up all the whitespace (including -- blank lines) until we find a non-whitespace character, then do layout -- processing. @@ -371,8 +374,16 @@ } <0,option_prags> { - "{-#" { warnThen PsWarnUnrecognisedPragma - (nested_comment ) } + +-- This code would eagerly accept and hence discard, e.g., "LANGUAGE MagicHash". +-- "{-#" $whitechar* $pragmachar+ +-- $whitechar+ $pragmachar+ +-- { warn_unknown_prag twoWordPrags } + + "{-#" $whitechar* $pragmachar+ + { warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) } + + "{-#" { warn_unknown_prag Map.empty } } -- '0' state: ordinary lexemes @@ -443,7 +454,8 @@ } <0> { - "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid } + "#" $idchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid } + "#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label } } <0> { @@ -482,28 +494,20 @@ @conid "#"+ / { ifExtension MagicHashBit } { idtoken conid } } --- Operators classified into prefix, suffix, tight infix, and loose infix. --- See Note [Whitespace-sensitive operator parsing] -<0> { - @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix } - @varsym / { followedByOpeningToken } { varsym_prefix } - @varsym / { precededByClosingToken } { varsym_suffix } - @varsym { varsym_loose_infix } -} - -- ToDo: - move `var` and (sym) into lexical syntax? -- - remove backquote from $special? <0> { @qvarsym { idtoken qvarsym } @qconsym { idtoken qconsym } - @consym { consym } + @varsym { with_op_ws varsym } + @consym { with_op_ws consym } } -- For the normal boxed literals we need to be careful -- when trying to be close to Haskell98 -- Note [Lexing NumericUnderscores extension] (#14473) --- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- NumericUnderscores extension allows underscores in numeric literals. -- Multiple underscores are represented with @numspc macro. -- To be simpler, we have only the definitions with underscores. @@ -699,6 +703,14 @@ { +-- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. +data OpWs + = OpWsPrefix -- a !b + | OpWsSuffix -- a! b + | OpWsTightInfix -- a!b + | OpWsLooseInfix -- a ! b + deriving Show + -- ----------------------------------------------------------------------------- -- The token type @@ -840,7 +852,10 @@ | ITqconsym (FastString,FastString) | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITlabelvarid FastString -- Overloaded label: #x + | ITlabelvarid SourceText FastString -- Overloaded label: #x + -- The SourceText is required because we can + -- have a string literal as a label + -- Note [Literal source text] in "GHC.Types.Basic" | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.Basic" | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic" @@ -1057,9 +1072,6 @@ ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) - -- For 'forall a . t' - ,(".", ITdot, NormalSyntax, 0 ) - ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) @@ -1088,60 +1100,66 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token) +type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token) special :: Token -> Action -special tok span _buf _len = return (L span tok) +special tok span _buf _len _buf2 = return (L span tok) token, layout_token :: Token -> Action -token t span _buf _len = return (L span t) -layout_token t span _buf _len = pushLexState layout >> return (L span t) +token t span _buf _len _buf2 = return (L span t) +layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t) idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len = return (L span $! (f buf len)) +idtoken f span buf len _buf2 = return (L span $! (f buf len)) qdo_token :: (Maybe FastString -> Token) -> Action -qdo_token con span buf len = do +qdo_token con span buf len _buf2 = do maybe_layout token return (L span $! token) where !token = con $! Just $! fst $! splitQualName buf len False skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len +skip_one_varid f span buf len _buf2 = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) +skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action +skip_one_varid_src f span buf len _buf2 + = return (L span $! f (SourceText $ lexemeToString (stepOn buf) (len-1)) + (lexemeToFastString (stepOn buf) (len-1))) + skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len +skip_two_varid f span buf len _buf2 = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) strtoken :: (String -> Token) -> Action -strtoken f span buf len = +strtoken f span buf len _buf2 = return (L span $! (f $! lexemeToString buf len)) begin :: Int -> Action -begin code _span _str _len = do pushLexState code; lexToken +begin code _span _str _len _buf2 = do pushLexState code; lexToken pop :: Action -pop _span _buf _len = do _ <- popLexState - lexToken +pop _span _buf _len _buf2 = + do _ <- popLexState + lexToken -- See Note [Nested comment line pragmas] failLinePrag1 :: Action -failLinePrag1 span _buf _len = do +failLinePrag1 span _buf _len _buf2 = do b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else lexError LexErrorInPragma -- See Note [Nested comment line pragmas] popLinePrag1 :: Action -popLinePrag1 span _buf _len = do +popLinePrag1 span _buf _len _buf2 = do b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else do _ <- popLexState lexToken hopefully_open_brace :: Action -hopefully_open_brace span buf len +hopefully_open_brace span buf len buf2 = do relaxed <- getBit RelaxedLayoutBit ctx <- getContext (AI l _) <- getInput @@ -1150,17 +1168,23 @@ case ctx of Layout prev_off _ : _ -> prev_off < offset _ -> True - if isOK then pop_and open_brace span buf len + if isOK then pop_and open_brace span buf len buf2 else addFatalError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock pop_and :: Action -> Action -pop_and act span buf len = do _ <- popLexState - act span buf len +pop_and act span buf len buf2 = + do _ <- popLexState + act span buf len buf2 -- See Note [Whitespace-sensitive operator parsing] -followedByOpeningToken :: AlexAccPred ExtsBitmap -followedByOpeningToken _ _ _ (AI _ buf) +followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap +followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf +precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf + +-- The input is the buffer *after* the token. +followedByOpeningToken' :: StringBuffer -> Bool +followedByOpeningToken' buf | atEnd buf = False | otherwise = case nextChar buf of @@ -1174,9 +1198,9 @@ ('⦇', _) -> True (c, _) -> isAlphaNum c --- See Note [Whitespace-sensitive operator parsing] -precededByClosingToken :: AlexAccPred ExtsBitmap -precededByClosingToken _ (AI _ buf) _ _ = +-- The input is the buffer *before* the token. +precededByClosingToken' :: StringBuffer -> Bool +precededByClosingToken' buf = case prevChar buf '\n' of '}' -> decodePrevNChars 1 buf /= "-" ')' -> True @@ -1188,6 +1212,19 @@ '⦈' -> True c -> isAlphaNum c +get_op_ws :: StringBuffer -> StringBuffer -> OpWs +get_op_ws buf1 buf2 = + mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2) + where + mk_op_ws False True = OpWsPrefix + mk_op_ws True False = OpWsSuffix + mk_op_ws True True = OpWsTightInfix + mk_op_ws False False = OpWsLooseInfix + +{-# INLINE with_op_ws #-} +with_op_ws :: (OpWs -> Action) -> Action +with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2 + {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) @@ -1284,7 +1321,7 @@ = p1 userState in1 len in2 || p2 userState in1 len in2 multiline_doc_comment :: Action -multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker +multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker where worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input where @@ -1330,11 +1367,11 @@ Nothing -> input lineCommentToken :: Action -lineCommentToken span buf len = do +lineCommentToken span buf len buf2 = do b <- getBit RawTokenStreamBit if b then do lt <- getLastLocComment - strtoken (\s -> ITlineComment s lt) span buf len + strtoken (\s -> ITlineComment s lt) span buf len buf2 else lexToken @@ -1343,7 +1380,7 @@ using regular expressions. -} nested_comment :: Action -nested_comment span buf len = {-# SCC "nested_comment" #-} do +nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do l <- getLastLocComment let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span input <- getInput @@ -1352,7 +1389,7 @@ nested_comment_logic endComment start_decorator input span nested_doc_comment :: Action -nested_doc_comment span buf _len = {-# SCC "nested_doc_comment" #-} withLexedDocType worker +nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker where worker input docType _checkNextLine = nested_comment_logic endComment "" input span where @@ -1491,7 +1528,7 @@ -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action -rulePrag span buf len = do +rulePrag span buf len _buf2 = do setExts (.|. xbit InRulePragBit) let !src = lexemeToString buf len return (L span (ITrules_prag (SourceText src))) @@ -1499,26 +1536,26 @@ -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' linePrag :: Action -linePrag span buf len = do +linePrag span buf len buf2 = do usePosPrags <- getBit UsePosPragsBit if usePosPrags - then begin line_prag2 span buf len + then begin line_prag2 span buf len buf2 else let !src = lexemeToString buf len in return (L span (ITline_prag (SourceText src))) -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' columnPrag :: Action -columnPrag span buf len = do +columnPrag span buf len buf2 = do usePosPrags <- getBit UsePosPragsBit let !src = lexemeToString buf len if usePosPrags - then begin column_prag span buf len + then begin column_prag span buf len buf2 else let !src = lexemeToString buf len in return (L span (ITcolumn_prag (SourceText src))) endPrag :: Action -endPrag span _buf _len = do +endPrag span _buf _len _buf2 = do setExts (.&. complement (xbit InRulePragBit)) return (L span ITclose_prag) @@ -1562,11 +1599,11 @@ (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) open_brace, close_brace :: Action -open_brace span _str _len = do +open_brace span _str _len _buf2 = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) -close_brace span _str _len = do +close_brace span _str _len _buf2 = do popContext return (L span ITccurly) @@ -1609,7 +1646,7 @@ qual_size = orig_buf `byteDiff` dot_buf varid :: Action -varid span buf len = +varid span buf len _buf2 = case lookupUFM reservedWordsFM fs of Just (ITcase, _) -> do lastTk <- getLastTk @@ -1655,8 +1692,8 @@ qconsym buf len = ITqconsym $! splitQualName buf len False -- See Note [Whitespace-sensitive operator parsing] -varsym_prefix :: Action -varsym_prefix = sym $ \span exts s -> +varsym :: OpWs -> Action +varsym opws@OpWsPrefix = sym $ \span exts s -> let warnExtConflict errtok = do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) ; return (ITvarsym s) } @@ -1684,55 +1721,54 @@ | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise -> - do { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix) + do { warnOperatorWhitespace opws span s ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_suffix :: Action -varsym_suffix = sym $ \span _ s -> +varsym opws@OpWsSuffix = sym $ \span _ s -> if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) | s == fsLit "." -> return ITdot | otherwise -> - do { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix) + do { warnOperatorWhitespace opws span s ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_tight_infix :: Action -varsym_tight_infix = sym $ \span exts s -> +varsym opws@OpWsTightInfix = sym $ \span exts s -> if | s == fsLit "@" -> return ITat | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) | s == fsLit "." -> return ITdot | otherwise -> - do { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix)) - ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_loose_infix :: Action -varsym_loose_infix = sym $ \_ _ s -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym OpWsLooseInfix = sym $ \_ _ s -> if | s == fsLit "." -> return ITdot | otherwise -> return $ ITvarsym s -consym :: Action -consym = sym (\_span _exts s -> return $ ITconsym s) +consym :: OpWs -> Action +consym opws = sym $ \span _exts s -> + do { warnOperatorWhitespace opws span s + ; return (ITconsym s) } +warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P () +warnOperatorWhitespace opws span s = + whenIsJust (check_unusual_opws opws) $ \opws' -> + addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s opws') + +-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix). +-- This determines if -Woperator-whitespace is triggered. +check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence +check_unusual_opws opws = + case opws of + OpWsPrefix -> Just OperatorWhitespaceOccurrence_Prefix + OpWsSuffix -> Just OperatorWhitespaceOccurrence_Suffix + OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix + OpWsLooseInfix -> Nothing + sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action -sym con span buf len = +sym con span buf len _buf2 = case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> do - exts <- getExts - if fs == fsLit "." && - exts .&. (xbit OverloadedRecordDotBit) /= 0 && - xtest OverloadedRecordDotBit exts - then L span <$!> con span exts fs -- Process by varsym_*. - else return $ L span keyword + Just (keyword, NormalSyntax, 0) -> + return $ L span keyword Just (keyword, NormalSyntax, i) -> do exts <- getExts if exts .&. i /= 0 @@ -1760,7 +1796,7 @@ -> Int -> Int -> (Integer, (Char -> Int)) -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do numericUnderscores <- getBit NumericUnderscoresBit -- #14473 let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do @@ -1802,7 +1838,7 @@ -- readSignificandExponentPair can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action -tok_frac drop f span buf len = do +tok_frac drop f span buf len _buf2 = do numericUnderscores <- getBit NumericUnderscoresBit -- #14473 let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do @@ -1837,7 +1873,7 @@ -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action -do_bol span _str _len = do +do_bol span _str _len _buf2 = do -- See Note [Nested comment line pragmas] b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else do @@ -1888,7 +1924,7 @@ -- by a 'do', then we allow the new context to be at the same indentation as -- the previous context. This is what the 'strict' argument is for. new_layout_context :: Bool -> Bool -> Token -> Action -new_layout_context strict gen_semic tok span _buf len = do +new_layout_context strict gen_semic tok span _buf len _buf2 = do _ <- popLexState (AI l _) <- getInput let offset = srcLocCol (psRealLoc l) - len @@ -1907,7 +1943,7 @@ return (L span tok) do_layout_left :: Action -do_layout_left span _buf _len = do +do_layout_left span _buf _len _buf2 = do _ <- popLexState pushLexState bol -- we must be at the start of a line return (L span ITvccurly) @@ -1916,7 +1952,7 @@ -- LINE pragmas setLineAndFile :: Int -> Action -setLineAndFile code (PsSpan span _) buf len = do +setLineAndFile code (PsSpan span _) buf len _buf2 = do let src = lexemeToString buf (len - 1) -- drop trailing quotation mark linenumLen = length $ head $ words src linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit @@ -1943,7 +1979,7 @@ lexToken setColumn :: Action -setColumn (PsSpan span _) buf len = do +setColumn (PsSpan span _) buf len _buf2 = do let column = case reads (lexemeToString buf len) of [(column, _)] -> column @@ -1969,7 +2005,7 @@ mkTok' s _ = mkTok s lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action -lex_string_prag_comment mkTok span _buf _len +lex_string_prag_comment mkTok span _buf _len _buf2 = do input <- getInput start <- getParsedLoc l <- getLastLocComment @@ -1998,65 +2034,97 @@ -- This stuff is horrible. I hates it. lex_string_tok :: Action -lex_string_tok span buf _len = do - tok <- lex_string "" +lex_string_tok span buf _len _buf2 = do + lexed <- lex_string (AI end bufEnd) <- getInput let - tok' = case tok of - ITprimstring _ bs -> ITprimstring (SourceText src) bs - ITstring _ s -> ITstring (SourceText src) s - _ -> panic "lex_string_tok" + tok = case lexed of + LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s) + LexedRegularString s -> ITstring (SourceText src) (mkFastString s) src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkPsSpan (psSpanStart span) end) tok') + return $ L (mkPsSpan (psSpanStart span) end) tok -lex_string :: String -> P Token -lex_string s = do + +lex_quoted_label :: Action +lex_quoted_label span buf _len _buf2 = do + start <- getInput + s <- lex_string_helper "" start + (AI end bufEnd) <- getInput + let + token = ITlabelvarid (SourceText src) (mkFastString s) + src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1) + start = psSpanStart span + + return $ L (mkPsSpan start end) token + + +data LexedString = LexedRegularString String | LexedPrimString String + +lex_string :: P LexedString +lex_string = do + start <- getInput + s <- lex_string_helper "" start + magicHash <- getBit MagicHashBit + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + when (any (> '\xFF') s) $ do + pState <- getPState + let msg = PsErrPrimStringInvalidChar + let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + addError err + return $ LexedPrimString s + _other -> + return $ LexedRegularString s + else + return $ LexedRegularString s + + +lex_string_helper :: String -> AlexInput -> P String +lex_string_helper s start = do i <- getInput case alexGetChar' i of Nothing -> lit_error i Just ('"',i) -> do - setInput i - let s' = reverse s - magicHash <- getBit MagicHashBit - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - when (any (> '\xFF') s') $ do - pState <- getPState - let msg = PsErrPrimStringInvalidChar - let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg - addError err - return (ITprimstring (SourceText s') (unsafeMkByteString s')) - _other -> - return (ITstring (SourceText s') (mkFastString s')) - else - return (ITstring (SourceText s') (mkFastString s')) + setInput i + return (reverse s) Just ('\\',i) | Just ('&',i) <- next -> do - setInput i; lex_string s + setInput i; lex_string_helper s start | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s + setInput i; lex_stringgap s start where next = alexGetChar' i Just (c, i1) -> do case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) - c | isAny c -> do setInput i1; lex_string (c:s) + '\\' -> do setInput i1; c' <- lex_escape; lex_string_helper (c':s) start + c | isAny c -> do setInput i1; lex_string_helper (c:s) start + _other | any isDoubleSmartQuote s -> do + -- if the built-up string s contains a smart double quote character, it was + -- likely the reason why the string literal was not lexed correctly + setInput start -- rewind to the first character in the string literal + -- so we can find the smart quote character's location + advance_to_smart_quote_character + i2@(AI loc _) <- getInput + case alexGetChar' i2 of + Just (c, _) -> do add_nonfatal_smart_quote_error c loc; lit_error i + Nothing -> lit_error i -- should never get here _other -> lit_error i -lex_stringgap :: String -> P Token -lex_stringgap s = do + +lex_stringgap :: String -> AlexInput -> P String +lex_stringgap s start = do i <- getInput c <- getCharOrFail i case c of - '\\' -> lex_string s - c | c <= '\x7f' && is_space c -> lex_stringgap s + '\\' -> lex_string_helper s start + c | c <= '\x7f' && is_space c -> lex_stringgap s start -- is_space only works for <= '\x7f' (#3751, #5425) _other -> lit_error i @@ -2068,7 +2136,7 @@ -- (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok span buf _len = do -- We've seen ' +lex_char_tok span buf _len _buf2 = do -- We've seen ' i1 <- getInput -- Look ahead to first character let loc = psSpanStart span case alexGetChar' i1 of @@ -2078,15 +2146,16 @@ setInput i2 return (L (mkPsSpan loc end2) ITtyQuote) - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + Just ('\\', i2@(AI end2 _)) -> do -- We've seen 'backslash setInput i2 lit_ch <- lex_escape i3 <- getInput mc <- getCharOrFail i3 -- Trailing quote if mc == '\'' then finish_char_tok buf loc lit_ch - else lit_error i3 + else if isSingleSmartQuote mc then add_smart_quote_error mc end2 + else lit_error i3 - Just (c, i2@(AI _end2 _)) + Just (c, i2@(AI end2 _)) | not (isAny c) -> lit_error i1 | otherwise -> @@ -2096,6 +2165,7 @@ Just ('\'', i3) -> do -- We've seen 'x' setInput i3 finish_char_tok buf loc c + Just (c, _) | isSingleSmartQuote c -> add_smart_quote_error c end2 _other -> do -- We've seen 'x not followed by quote -- (including the possibility of EOF) -- Just parse the quote only @@ -2110,10 +2180,12 @@ let src = lexemeToString buf (cur bufEnd - cur buf) if magicHash then do case alexGetChar' i of - Just ('#',i@(AI end _)) -> do + Just ('#',i@(AI end bufEnd')) -> do setInput i + -- Include the trailing # in SourceText + let src' = lexemeToString buf (cur bufEnd' - cur buf) return (L (mkPsSpan loc end) - (ITprimchar (SourceText src) ch)) + (ITprimchar (SourceText src') ch)) _other -> return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) @@ -2126,7 +2198,7 @@ lex_escape :: P Char lex_escape = do - i0 <- getInput + i0@(AI loc _) <- getInput c <- getCharOrFail i0 case c of 'a' -> return '\a' @@ -2139,6 +2211,11 @@ '\\' -> return '\\' '"' -> return '\"' '\'' -> return '\'' + -- the next two patterns build up a Unicode smart quote error (#21843) + smart_double_quote | isDoubleSmartQuote smart_double_quote -> + add_smart_quote_error smart_double_quote loc + smart_single_quote | isSingleSmartQuote smart_single_quote -> + add_smart_quote_error smart_single_quote loc '^' -> do i1 <- getInput c <- getCharOrFail i1 if c >= '@' && c <= '_' @@ -2246,7 +2323,7 @@ -- QuasiQuote lex_qquasiquote_tok :: Action -lex_qquasiquote_tok span buf len = do +lex_qquasiquote_tok span buf len _buf2 = do let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False quoteStart <- getParsedLoc quote <- lex_quasiquote (psRealLoc quoteStart) "" @@ -2258,7 +2335,7 @@ mkPsSpan quoteStart end))) lex_quasiquote_tok :: Action -lex_quasiquote_tok span buf len = do +lex_quasiquote_tok span buf len _buf2 = do let quoter = tail (lexemeToString buf (len - 1)) -- 'tail' drops the initial '[', -- while the -1 drops the trailing '|' @@ -2294,17 +2371,60 @@ (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) -- ----------------------------------------------------------------------------- +-- Unicode Smart Quote detection (#21843) + +isDoubleSmartQuote :: Char -> Bool +isDoubleSmartQuote '“' = True +isDoubleSmartQuote '”' = True +isDoubleSmartQuote _ = False + +isSingleSmartQuote :: Char -> Bool +isSingleSmartQuote '‘' = True +isSingleSmartQuote '’' = True +isSingleSmartQuote _ = False + +isSmartQuote :: AlexAccPred ExtsBitmap +isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c + +smart_quote_error_message :: Char -> PsLoc -> MsgEnvelope PsMessage +smart_quote_error_message c loc = + let (correct_char, correct_char_name) = + if isSingleSmartQuote c then ('\'', "Single Quote") else ('"', "Quotation Mark") + err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $ + PsErrUnicodeCharLooksLike c correct_char correct_char_name in + err + +smart_quote_error :: Action +smart_quote_error span buf _len _buf2 = do + let c = currentChar buf + addFatalError (smart_quote_error_message c (psSpanStart span)) + +add_smart_quote_error :: Char -> PsLoc -> P a +add_smart_quote_error c loc = addFatalError (smart_quote_error_message c loc) + +add_nonfatal_smart_quote_error :: Char -> PsLoc -> P () +add_nonfatal_smart_quote_error c loc = addError (smart_quote_error_message c loc) + +advance_to_smart_quote_character :: P () +advance_to_smart_quote_character = do + i <- getInput + case alexGetChar' i of + Just (c, _) | isDoubleSmartQuote c -> return () + Just (_, i2) -> do setInput i2; advance_to_smart_quote_character + Nothing -> return () -- should never get here + +-- ----------------------------------------------------------------------------- -- Warnings warnTab :: Action -warnTab srcspan _buf _len = do +warnTab srcspan _buf _len _buf2 = do addTabWarning (psRealSpan srcspan) lexToken warnThen :: PsMessage -> Action -> Action -warnThen warning action srcspan buf len = do +warnThen warning action srcspan buf len buf2 = do addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning - action srcspan buf len + action srcspan buf len buf2 -- ----------------------------------------------------------------------------- -- The Parse Monad @@ -2431,7 +2551,7 @@ -- implement pushCurrentContext (which is only called from one place). -- AZ question: setLastToken which sets last_loc and last_len - -- is called whan processing AlexToken, immediately prior to + -- is called when processing AlexToken, immediately prior to -- calling the action in the token. So from the perspective -- of the action, it is the *current* token. Do I understand -- correctly? @@ -3401,7 +3521,7 @@ let span = mkPsSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes - lt <- t span buf bytes + lt <- t span buf bytes buf2 let lt' = unLoc lt if (isComment lt') then setLastComment lt else setLastTk lt return lt @@ -3490,9 +3610,10 @@ ] dispatch_pragmas :: Map String Action -> Action -dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len - Nothing -> lexError LexUnknownPragma +dispatch_pragmas prags span buf len buf2 = + case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len buf2 + Nothing -> lexError LexUnknownPragma known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) @@ -3513,7 +3634,14 @@ _ -> prag' canon_ws s = unwords (map canonical (words s)) - +warn_unknown_prag :: Map String Action -> Action +warn_unknown_prag prags span buf len buf2 = do + let uppercase = map toUpper + unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) + suggestions = map uppercase (Map.keys prags) + addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ + PsWarnUnrecognisedPragma unknown_prag suggestions + nested_comment span buf len buf2 {- %************************************************************************ @@ -3528,7 +3656,7 @@ -- 'AddEpAnn' values for the opening and closing bordering on the start -- and end of the span mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn) -mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc)) +mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing)) where f = srcSpanFile ss sl = srcSpanStartLine ss @@ -3556,6 +3684,25 @@ in (comment_q', reverse newAnns) +-- Comments appearing without a line-break before the first +-- declaration are associated with the declaration +splitPriorComments + :: RealSrcSpan + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +splitPriorComments ss prior_comments = + let + -- True if there is only one line between the earlier and later span + cmp later earlier + = srcSpanStartLine later - srcSpanEndLine earlier == 1 + + go decl _ [] = ([],decl) + go decl r (c@(L l _):cs) = if cmp r (anchor l) + then go (c:decl) (anchor l) cs + else (reverse (c:cs), decl) + in + go [] ss prior_comments + allocatePriorComments :: RealSrcSpan -> [LEpaComment] @@ -3564,12 +3711,15 @@ allocatePriorComments ss comment_q mheader_comments = let cmp (L l _) = anchor l <= ss - (before,after) = partition cmp comment_q - newAnns = before + (newAnns,after) = partition cmp comment_q comment_q'= after + (prior_comments, decl_comments) + = case mheader_comments of + Strict.Nothing -> (reverse newAnns, []) + _ -> splitPriorComments ss newAnns in case mheader_comments of - Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', []) + Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments) Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns) allocateFinalComments diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -9,8 +10,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- -- (c) The University of Glasgow 2002-2006 -- @@ -39,6 +38,7 @@ fromSpecTyVarBndr, fromSpecTyVarBndrs, annBinds, fixValbindsAnn, + stmtsAnchor, stmtsLoc, cvBindGroup, cvBindsAndSigs, @@ -94,8 +94,8 @@ warnStarIsType, warnPrepositiveQualifiedModule, failOpFewArgs, - failOpNotEnabledImportQualifiedPost, - failOpImportQualifiedTwice, + failNotEnabledImportQualifiedPost, + failImportQualifiedTwice, SumOrTuple (..), @@ -124,7 +124,6 @@ import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name -import GHC.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity @@ -136,10 +135,11 @@ 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 ) @@ -157,6 +157,8 @@ import GHC.Utils.Panic.Plain import qualified GHC.Data.Strict as Strict +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.Char @@ -190,7 +192,7 @@ -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) - -> LayoutInfo + -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs) @@ -201,7 +203,8 @@ ; tyvars <- checkTyVars (text "class") whereDots cls tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) + ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey) + , tcdLayout = layoutInfo , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity @@ -212,6 +215,7 @@ , tcdDocs = docs })) } mkTyData :: SrcSpan + -> Bool -> NewOrData -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -220,36 +224,35 @@ -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LTyClDecl GhcPs) -mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) +mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons (L _ maybe_deriv) annsIn = do { let loc = noAnnSrcSpan loc' ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdDExt = anns', tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } -mkDataDefn :: NewOrData - -> Maybe (LocatedP CType) +mkDataDefn :: Maybe (LocatedP CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] + -> DataDefnCons (LConDecl GhcPs) -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; return (HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType + , dd_cType = cType , dd_ctxt = mcxt , dd_cons = data_cons , dd_kindSig = ksig , dd_derivs = maybe_deriv }) } - mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS @@ -324,7 +327,8 @@ = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl (FamEqn { feqn_ext = fam_eqn_ans , feqn_tycon = tc @@ -398,19 +402,19 @@ -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do + | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do + | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) | otherwise = do cs <- getCommentsFor (locA loc) return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField - (L loc (mkUntypedSplice noAnn BareSplice lexpr)) - ImplicitSplice) + (L loc (HsUntypedSpliceExpr noAnn lexpr)) + BareSplice) mkRoleAnnotDecl :: SrcSpan -> LocatedN RdrName -- type being annotated @@ -467,13 +471,13 @@ annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList -add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2 +add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2 | valid_anchor (anchor a) = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2) | otherwise = EpAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2) -add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs +add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs = EpAnn (Anchor rs UnchangedAnchor) (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where" @@ -494,6 +498,18 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs) +-- | The 'Anchor' for a stmtlist is based on either the location or +-- the first semicolon annotion. +stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor +stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _)) + = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r +stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor + +stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan +stmtsLoc (L l ((ConsOL aa _), _)) + = widenSpan l [aa] +stmtsLoc (L l _) = l + {- ********************************************************************** #cvBinds-etc# Converting to @HsBinds@, etc. @@ -674,7 +690,7 @@ fromDecl (L loc decl@(ValD _ (PatBind _ -- AZ: where should these anns come from? pat@(L _ (ConPat noAnn ln@(L _ name) details)) - rhs _))) = + rhs))) = do { unless (name == patsyn_name) $ wrongNameBindingErr (locA loc) decl ; match <- case details of @@ -737,11 +753,11 @@ -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. mkGadtDecl :: SrcSpan - -> [LocatedN RdrName] + -> NonEmpty (LocatedN RdrName) + -> LHsUniToken "::" "∷" GhcPs -> LHsSigType GhcPs - -> [AddEpAnn] -> P (LConDecl GhcPs) -mkGadtDecl loc names ty annsIn = do +mkGadtDecl loc names dcol ty = do cs <- getCommentsFor loc let l = noAnnSrcSpan loc @@ -761,11 +777,12 @@ let (anns, cs, arg_types, res_type) = splitHsFunType body_ty return (PrefixConGADT arg_types, res_type, anns, cs) - let an = EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) + let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa) pure $ L l ConDeclGADT { con_g_ext = an , con_names = names + , con_dcolon = dcol , con_bndrs = L (getLoc ty) outer_bndrs , con_mb_cxt = mcxt , con_g_args = args @@ -947,8 +964,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = - -- TODO: don't use string here, OccName has a Unique/FastString - when ((occNameString occ ==) `any` ["forall","family","role"]) + when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"]) (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrParseErrorOnInput occ)) check _ = panic "checkRuleTyVarBndrNames" @@ -991,7 +1007,7 @@ -- workaround to define '*' despite StarIsType go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix = do { addPsMessage (locA l) PsWarnStarBinder - ; let name = mkOccName tcClsName (starSym isUni) + ; let name = mkOccNameFS tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix , (reverse ops') ++ cps') } @@ -1023,13 +1039,13 @@ newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (realSrcSpan l) (anchor as) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs) + an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs) in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) newAnns _ EpAnnNotUsed = panic "missing AnnParen" newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (anchor ap) (anchor as) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs)) + an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs)) in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) -- | Yield a parse error if we have a function applied directly to a do block @@ -1116,13 +1132,13 @@ -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. @@ -1144,7 +1160,7 @@ checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] +checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | isRdrDataCon c = return . L loc $ ConPat @@ -1157,8 +1173,8 @@ | (not (null args) && patIsRec c) = do ctx <- askParseContext patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx -checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = - checkPat loc f (t : tyargs) args +checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args = + checkPat loc f (HsConPatTyArg at t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e checkPat loc f [] (p : args) @@ -1293,8 +1309,7 @@ makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, - fun_matches = mkMatchGroup FromSource ms, - fun_tick = [] } + fun_matches = mkMatchGroup FromSource ms } -- See Note [FunBind vs PatBind] checkPatBind :: SrcSpan @@ -1316,7 +1331,7 @@ checkPatBind loc annsIn lhs (L _ grhss) = do cs <- getCommentsFor loc - return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[])) + return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss) checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) @@ -1516,7 +1531,7 @@ -- | Disambiguate "f x" (function application) mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) -- | Disambiguate "f @t" (visible type application) - mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs @@ -1549,7 +1564,7 @@ -- | Disambiguate "[a,b,c]" (list syntax) mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) - mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) + mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: Bool -> -- Is OverloadedRecordUpdate in effect? @@ -1569,7 +1584,7 @@ :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "a@b" (as-pattern) mkHsAsPatPV - :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) + :: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b) -- | Disambiguate "~a" (lazy pattern) mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "!a" (bang pattern) @@ -1675,8 +1690,8 @@ mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs _ = cmdFail l $ - brackets (fsep (punctuate comma (map ppr xs))) - mkHsSplicePV (L l sp) = cmdFail l (ppr sp) + brackets (pprWithCommas ppr xs) + mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp) mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps) @@ -1689,7 +1704,7 @@ in pp_op <> ppr c mkHsViewPatPV l a b _ = cmdFail l $ ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c _ = cmdFail l $ + mkHsAsPatPV l v _ c = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c mkHsLazyPatPV l c _ = cmdFail l $ text "~" <> ppr c @@ -1743,9 +1758,9 @@ checkExpBlockArguments e1 checkExpBlockArguments e2 return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) - mkHsAppTypePV l e la t = do + mkHsAppTypePV l e at t = do checkExpBlockArguments e - return $ L l (HsAppType la e (mkHsWildCardBndrs t)) + return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t)) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b cs <- getCommentsFor l @@ -1772,7 +1787,7 @@ return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs) mkHsSplicePV sp@(L l _) = do cs <- getCommentsFor l - return $ mapLoc (HsSpliceE (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp + return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do cs <- getCommentsFor l r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs) @@ -1785,7 +1800,7 @@ return $ L l (SectionR (comment (realSrcSpan l) cs) op e) mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) + mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) @@ -1800,7 +1815,7 @@ rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs -hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") +hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_"))) type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL @@ -1825,10 +1840,10 @@ type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p la t = do + mkHsAppTypePV l p at t = do cs <- getCommentsFor (locA l) - let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs - return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) + let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs + return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) @@ -1867,10 +1882,10 @@ p <- checkLPat b cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p)) - mkHsAsPatPV l v e a = do + mkHsAsPatPV l v at e = do p <- checkLPat e cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) a cs) v p)) + return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) NoEpAnns cs) v at p)) mkHsLazyPatPV l e a = do p <- checkLPat e cs <- getCommentsFor l @@ -2497,10 +2512,10 @@ | isRdrDataCon c = do let (fs, ps) = partitionEithers fbinds - if not (null ps) - then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $ - PsErrOverloadedRecordDotInvalid - else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) + case ps of + p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + PsErrOverloadedRecordDotInvalid + _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ PsErrDotsInRecordUpdate @@ -2530,15 +2545,13 @@ [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] - if not $ null qualifiedFields - then - addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $ + case qualifiedFields of + qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ PsErrOverloadedRecordUpdateNoQualifiedFields - else -- This is a RecordDotSyntax update. - return RecordUpd { - rupd_ext = anns - , rupd_expr = exp - , rupd_flds = Right (toProjUpdates fbinds) } + _ -> return RecordUpd -- This is a RecordDotSyntax update. + { rupd_ext = anns + , rupd_expr = exp + , rupd_flds = Right (toProjUpdates fbinds) } where toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) @@ -2549,7 +2562,7 @@ recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr - fl = DotFieldOcc noAnn (L loc f) + fl = DotFieldOcc noAnn (L loc (FieldLabelString f)) lf = locA loc in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns where @@ -2568,7 +2581,7 @@ mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (L s (length fs)) } + , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) @@ -2606,6 +2619,28 @@ , inl_rule = FunLike } +checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] + -> P (DataDefnCons (LConDecl GhcPs)) +checkNewOrData span name is_type_data = curry $ \ case + (NewType, [a]) -> pure $ NewTypeCon a + (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as) + (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) + where + -- In a "type data" declaration, the constructors are in the type/class + -- namespace rather than the data constructor namespace. + -- See Note [Type data declarations] in GHC.Rename.Module. + handle_type_data + | is_type_data = map (fmap promote_constructor) + | otherwise = id + + promote_constructor (dc@ConDeclGADT { con_names = cons }) + = dc { con_names = fmap (fmap promote_name) cons } + promote_constructor (dc@ConDeclH98 { con_name = con }) + = dc { con_name = fmap promote_name con } + promote_constructor dc = dc + + promote_name name = fromMaybe name (promoteRdrName name) + ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -2638,7 +2673,7 @@ PsErrMalformedEntityString Just importSpec -> return importSpec - isCWrapperImport (CImport _ _ _ CWrapper _) = True + isCWrapperImport (CImport _ _ _ _ CWrapper) = True isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in @@ -2649,7 +2684,7 @@ then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) + importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport { fd_i_ext = ann @@ -2665,7 +2700,7 @@ -- that one. parseCImport :: Located CCallConv -> Located Safety -> FastString -> String -> Located SourceText - -> Maybe ForeignImport + -> Maybe (ForeignImport (GhcPass p)) parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str @@ -2692,7 +2727,7 @@ | id_char c -> pfail _ -> return () - mk h n = CImport cconv safety h n sourceText + mk h n = CImport sourceText cconv safety h n hdr_char c = not (isSpace c) -- header files are filenames, which can contain @@ -2727,8 +2762,7 @@ mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) = return $ \ann -> ForD noExtField $ ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) - (L le esrc) } + , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2740,7 +2774,7 @@ -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) +mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm) -------------------------------------------------------------------------------- -- Help with module system imports/exports @@ -2774,7 +2808,7 @@ let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) - ies :: [LocatedA (IEWrappedName RdrName)] + ies :: [LocatedA (IEWrappedName GhcPs)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName -> IEThingWith ann (L l newName) pos ies) @@ -2793,11 +2827,12 @@ ieNameVal (ImpExpQcType _ ln) = unLoc ln ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType r ln) = IEType r ln + ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs + ieNameFromSpec (ImpExpQcName (L l n)) = IEName noExtField (L l n) + ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n) ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (mapLoc ieNameFromSpec) + wrapped = map (fmap ieNameFromSpec) mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space -> P (LocatedN RdrName) @@ -2820,7 +2855,7 @@ mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) mkImpExpSubSpec [L la ImpExpQcWildcard] = - return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll) + return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) @@ -2837,12 +2872,12 @@ warnPrepositiveQualifiedModule span = addPsMessage span PsWarnImportPreQualified -failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = +failNotEnabledImportQualifiedPost :: SrcSpan -> P () +failNotEnabledImportQualifiedPost loc = addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified -failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = +failImportQualifiedTwice :: SrcSpan -> P () +failImportQualifiedTwice loc = addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice warnStarIsType :: SrcSpan -> P () @@ -2873,6 +2908,7 @@ } data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + deriving (Foldable, Functor, Traversable) -- During parsing, we make use of several monadic effects: reporting parse errors, -- accumulating warnings, adding API annotations, and checking for extensions. These @@ -2894,9 +2930,7 @@ -- abParser :: forall x. DisambAB x => P (PV x) -- newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } - -instance Functor PV where - fmap = liftM + deriving (Functor) instance Applicative PV where pure a = a `seq` PV (\_ acc -> PV_Ok acc a) @@ -2971,7 +3005,7 @@ {- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set +A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984. Consider this example, where the user has forgotten a 'do': @@ -3090,14 +3124,14 @@ mkTokenLocation :: SrcSpan -> TokenLocation mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc -mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r) +mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb) -- Precondition: the TokenLocation has EpaSpan, never EpaDelta. token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation token_location_widenR NoTokenLoc _ = NoTokenLoc token_location_widenR tl (UnhelpfulSpan _) = tl -token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) = - (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2))) +token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) = + (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2))) token_location_widenR (TokenLoc (EpaDelta _ _)) _ = -- Never happens because the parser does not produce EpaDelta. panic "token_location_widenR: EpaDelta" @@ -3106,9 +3140,9 @@ ----------------------------------------------------------------------------- -- Token symbols -starSym :: Bool -> String -starSym True = "★" -starSym False = "*" +starSym :: Bool -> FastString +starSym True = fsLit "★" +starSym False = fsLit "*" ----------------------------------------- -- Bits and pieces for RecordDotSyntax. diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -48,7 +48,7 @@ -} module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where -import GHC.Prelude hiding (mod) +import GHC.Prelude hiding (head, init, last, mod, tail) import GHC.Hs @@ -60,6 +60,8 @@ import Data.Foldable import Data.Traversable import Data.Maybe +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -178,7 +180,7 @@ -- to a parsed HsModule. -- -- Reports badly positioned comments when -Winvalid-haddock is enabled. -addHaddockToModule :: Located HsModule -> P (Located HsModule) +addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs)) addHaddockToModule lmod = do pState <- getPState let all_comments = toList (hdk_comments pState) @@ -239,7 +241,7 @@ -- item4 -- ) where -- -instance HasHaddock (Located HsModule) where +instance HasHaddock (Located (HsModule GhcPs)) where addHaddock (L l_mod mod) = do -- Step 1, get the module header documentation comment: -- @@ -287,13 +289,13 @@ -- data C = MkC -- ^ Comment on MkC -- -- ^ Comment on C -- - let layout_info = hsmodLayout mod + let layout_info = hsmodLayout (hsmodExt mod) hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) pure $ L l_mod $ mod { hsmodExports = hsmodExports' , hsmodDecls = hsmodDecls' - , hsmodHaddockModHeader = join @Maybe headerDocs } + , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } } lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier @@ -338,7 +340,7 @@ The inputs to addHaddockInterleaveItems are: - * layout_info :: LayoutInfo + * layout_info :: LayoutInfo GhcPs In the example above, note that the indentation level inside the module is 2 spaces. It would be represented as layout_info = VirtualBraces 2. @@ -370,7 +372,7 @@ addHaddockInterleaveItems :: forall a. HasHaddock a - => LayoutInfo + => LayoutInfo GhcPs -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item -> [a] -- Unprocessed (non-documentation) items -> HdkA [a] -- Documentation items & processed non-documentation items @@ -387,7 +389,7 @@ with_layout_info :: HdkA a -> HdkA a with_layout_info = case layout_info of NoLayoutInfo -> id - ExplicitBraces -> id + ExplicitBraces{} -> id VirtualBraces n -> let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) @@ -496,7 +498,7 @@ -- -- ^ Comment on the second method -- addHaddock (TyClD _ decl) - | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout), + | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout, tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl = do @@ -507,7 +509,7 @@ flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) pure $ let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' - decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout) + decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs , tcdSigs = tcdSigs' , tcdMeths = tcdMeths' @@ -584,7 +586,7 @@ -- = MkT1 Int Bool -- ^ Comment on MkT1 -- | MkT2 Char Int -- ^ Comment on MkT2 -- - dd_cons' <- addHaddock (dd_cons defn) + dd_cons' <- traverse addHaddock (dd_cons defn) -- Process the deriving clauses: -- @@ -696,9 +698,9 @@ addHaddock (L l_con_decl con_decl) = extendHdkA (locA l_con_decl) $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do + ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. - con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names)) + con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names)) con_g_args' <- case con_g_args of PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts @@ -708,7 +710,7 @@ pure $ RecConGADT (L l_rec flds') arr con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ - ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, + ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } @@ -872,13 +874,13 @@ doc <- selectDocString trailingDocs return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) con_args' <- case con_args con_decl of - x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs - x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs - PrefixCon _ ts -> PrefixCon noTypeArgs <$> mapLastM mk_doc_ty ts + x@(PrefixCon _ ts) -> case nonEmpty ts of + Nothing -> x <$ reportExtraDocs trailingDocs + Just ts -> PrefixCon noTypeArgs . toList <$> mapLastM mk_doc_ty ts + x@(RecCon (L l_rec flds)) -> case nonEmpty flds of + Nothing -> x <$ reportExtraDocs trailingDocs + Just flds -> RecCon . L l_rec . toList <$> mapLastM mk_doc_fld flds InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2 - RecCon (L l_rec flds) -> do - flds' <- mapLastM mk_doc_fld flds - return (RecCon (L l_rec flds')) return $ L l (con_decl{ con_args = con_args' }) else do con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) @@ -1307,10 +1309,10 @@ * * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) -mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a +mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a -mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) +mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = @@ -1344,7 +1346,7 @@ -- -- ^ indent mismatch indent_mismatch = case layout_info of NoLayoutInfo -> False - ExplicitBraces -> False + ExplicitBraces{} -> False VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) @@ -1530,7 +1532,7 @@ -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] -mapLL f = map (mapLoc f) +mapLL f = map (fmap f) {- Note [Old solution: Haddock in the grammar] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1576,7 +1578,7 @@ We could use EPA (exactprint annotations) to fix this, but not without modification. For example, EpaLocation contains RealSrcSpan but not BufSpan. -Also, the fix would be more straghtforward after #19623. +Also, the fix would be more straightforward after #19623. For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs -} diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -55,7 +55,7 @@ = PatBuilderPat (Pat p) | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) + | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName) @@ -65,7 +65,7 @@ ppr (PatBuilderPat p) = ppr p ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 - ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t + ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -206,6 +206,7 @@ osElfTarget OSQNXNTO = False osElfTarget OSAIX = False osElfTarget OSHurd = True +osElfTarget OSWasi = False osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for @@ -262,6 +263,7 @@ ArchPPC_64 _ -> True ArchS390X -> True ArchRISCV64 -> True + ArchLoongArch64 -> True ArchAArch64 -- Apple's AArch64 ABI requires that the caller sign-extend -- small integer arguments. See diff --git a/compiler/GHC/Platform/LoongArch64.hs b/compiler/GHC/Platform/LoongArch64.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Platform/LoongArch64.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.LoongArch64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_loongarch64 1 +#include "CodeGen.Platform.h" diff --git a/compiler/GHC/Platform/Regs.hs b/compiler/GHC/Platform/Regs.hs --- a/compiler/GHC/Platform/Regs.hs +++ b/compiler/GHC/Platform/Regs.hs @@ -15,6 +15,8 @@ import qualified GHC.Platform.X86 as X86 import qualified GHC.Platform.X86_64 as X86_64 import qualified GHC.Platform.RISCV64 as RISCV64 +import qualified GHC.Platform.Wasm32 as Wasm32 +import qualified GHC.Platform.LoongArch64 as LoongArch64 import qualified GHC.Platform.NoRegs as NoRegs -- | Returns 'True' if this global register is stored in a caller-saves @@ -31,6 +33,8 @@ ArchARM {} -> ARM.callerSaves ArchAArch64 -> AArch64.callerSaves ArchRISCV64 -> RISCV64.callerSaves + ArchWasm32 -> Wasm32.callerSaves + ArchLoongArch64 -> LoongArch64.callerSaves arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.callerSaves @@ -53,6 +57,8 @@ ArchARM {} -> ARM.activeStgRegs ArchAArch64 -> AArch64.activeStgRegs ArchRISCV64 -> RISCV64.activeStgRegs + ArchWasm32 -> Wasm32.activeStgRegs + ArchLoongArch64 -> LoongArch64.activeStgRegs arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.activeStgRegs @@ -70,6 +76,8 @@ ArchARM {} -> ARM.haveRegBase ArchAArch64 -> AArch64.haveRegBase ArchRISCV64 -> RISCV64.haveRegBase + ArchWasm32 -> Wasm32.haveRegBase + ArchLoongArch64 -> LoongArch64.haveRegBase arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.haveRegBase @@ -87,6 +95,8 @@ ArchARM {} -> ARM.globalRegMaybe ArchAArch64 -> AArch64.globalRegMaybe ArchRISCV64 -> RISCV64.globalRegMaybe + ArchWasm32 -> Wasm32.globalRegMaybe + ArchLoongArch64 -> LoongArch64.globalRegMaybe arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.globalRegMaybe @@ -104,6 +114,8 @@ ArchARM {} -> ARM.freeReg ArchAArch64 -> AArch64.freeReg ArchRISCV64 -> RISCV64.freeReg + ArchWasm32 -> Wasm32.freeReg + ArchLoongArch64 -> LoongArch64.freeReg arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.freeReg diff --git a/compiler/GHC/Platform/Wasm32.hs b/compiler/GHC/Platform/Wasm32.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Platform/Wasm32.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.Wasm32 where + +import GHC.Prelude + +-- TODO +#define MACHREGS_NO_REGS 1 +-- #define MACHREGS_wasm32 1 +#include "CodeGen.Platform.h" diff --git a/compiler/GHC/Platform/Ways.hs b/compiler/GHC/Platform/Ways.hs --- a/compiler/GHC/Platform/Ways.hs +++ b/compiler/GHC/Platform/Ways.hs @@ -61,7 +61,7 @@ -- | A way -- --- Don't change the constructor order as it us used by `waysTag` to create a +-- Don't change the constructor order as it is used by `waysTag` to create a -- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). data Way = WayCustom String -- ^ for GHC API clients building custom variants diff --git a/compiler/GHC/Prelude.hs b/compiler/GHC/Prelude.hs --- a/compiler/GHC/Prelude.hs +++ b/compiler/GHC/Prelude.hs @@ -13,9 +13,8 @@ -- * Explicitly imports GHC.Prelude module GHC.Prelude - (module X - ,module Bits - ,shiftL, shiftR + (module GHC.Prelude + ,module GHC.Utils.Trace ) where @@ -47,54 +46,7 @@ extensions. -} -import Prelude as X hiding ((<>)) -import Data.Foldable as X (foldl') - -#if MIN_VERSION_base(4,16,0) -import GHC.Bits as Bits hiding (shiftL, shiftR) -# if defined(DEBUG) -import qualified GHC.Bits as Bits (shiftL, shiftR) -# endif - -#else ---base <4.15 -import Data.Bits as Bits hiding (shiftL, shiftR) -# if defined(DEBUG) -import qualified Data.Bits as Bits (shiftL, shiftR) -# endif -#endif - -{- Note [Default to unsafe shifts inside GHC] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The safe shifts can introduce branches which come -at the cost of performance. We still want the additional -debugability for debug builds. So we define it as one or the -other depending on the DEBUG setting. - -Why do we then continue on to re-export the rest of Data.Bits? -If we would not what is likely to happen is: -* Someone imports Data.Bits, uses xor. Things are fine. -* They add a shift and get an ambigious definition error. -* The are puzzled for a bit. -* They either: - + Remove the import of Data.Bits and get an error because xor is not in scope. - + Add the hiding clause to the Data.Bits import for the shifts. - -Either is quite annoying. Simply re-exporting all of Data.Bits avoids this -making for a smoother developer experience. At the cost of having a few more -names in scope at all time. But that seems like a fair tradeoff. - -See also #19618 --} +import GHC.Prelude.Basic as GHC.Prelude --- We always want the Data.Bits method to show up for rules etc. -{-# INLINE shiftL #-} -{-# INLINE shiftR #-} -shiftL, shiftR :: Bits.Bits a => a -> Int -> a -#if defined(DEBUG) -shiftL = Bits.shiftL -shiftR = Bits.shiftR -#else -shiftL = Bits.unsafeShiftL -shiftR = Bits.unsafeShiftR -#endif +-- import {-# SOURCE #-} GHC.Utils.Trace +import GHC.Utils.Trace hiding ( trace ) diff --git a/compiler/GHC/Prelude/Basic.hs b/compiler/GHC/Prelude/Basic.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Prelude/Basic.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] + +-- | Custom minimal GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.BasicPrelude or GHC.Prelude +-- * The later provides some functionality with within ghc itself +-- like pprTrace. + +module GHC.Prelude.Basic + (module X + ,Applicative (..) + ,module Bits + ,shiftL, shiftR + ) where + + +{- Note [-O2 Prelude] +~~~~~~~~~~~~~~~~~~~~~ +There is some code in GHC that is *always* compiled with -O[2] because +of it's impact on compile time performance. Some of this code might depend +on the definitions like shiftL being defined here being performant. + +So we always compile this module with -O2. It's (currently) tiny so I +have little reason to suspect this impacts overall GHC compile times +negatively. + +-} +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} + +import Prelude as X hiding ((<>), Applicative(..)) +import Control.Applicative (Applicative(..)) +import Data.Foldable as X (foldl') + +#if MIN_VERSION_base(4,16,0) +import GHC.Bits as Bits hiding (shiftL, shiftR) +# if defined(DEBUG) +import qualified GHC.Bits as Bits (shiftL, shiftR) +# endif + +#else +--base <4.15 +import Data.Bits as Bits hiding (shiftL, shiftR) +# if defined(DEBUG) +import qualified Data.Bits as Bits (shiftL, shiftR) +# endif +#endif + +{- Note [Default to unsafe shifts inside GHC] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The safe shifts can introduce branches which come +at the cost of performance. We still want the additional +debugability for debug builds. So we define it as one or the +other depending on the DEBUG setting. + +Why do we then continue on to re-export the rest of Data.Bits? +If we would not what is likely to happen is: +* Someone imports Data.Bits, uses xor. Things are fine. +* They add a shift and get an ambiguous definition error. +* The are puzzled for a bit. +* They either: + + Remove the import of Data.Bits and get an error because xor is not in scope. + + Add the hiding clause to the Data.Bits import for the shifts. + +Either is quite annoying. Simply re-exporting all of Data.Bits avoids this +making for a smoother developer experience. At the cost of having a few more +names in scope at all time. But that seems like a fair tradeoff. + +See also #19618 +-} + +-- We always want the Data.Bits method to show up for rules etc. +{-# INLINE shiftL #-} +{-# INLINE shiftR #-} +shiftL, shiftR :: Bits.Bits a => a -> Int -> a +#if defined(DEBUG) +shiftL = Bits.shiftL +shiftR = Bits.shiftR +#else +shiftL = Bits.unsafeShiftL +shiftR = Bits.unsafeShiftR +#endif diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -10,7 +10,7 @@ , icReaderEnv , icInteractiveModule , icInScopeTTs - , icPrintUnqual + , icNamePprCtx ) where @@ -198,7 +198,7 @@ It would be correct ot re-construct the env from scratch based on -`ic_tythings`, but that'd be quite expensive if there are many entires in +`ic_tythings`, but that'd be quite expensive if there are many entries in `ic_tythings` that shadow each other. Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that @@ -285,7 +285,7 @@ ic_plugins :: !Plugins -- ^ Cache of loaded plugins. We store them here to avoid having to - -- load them everytime we switch to the interctive context. + -- load them every time we switch to the interactive context. } data InteractiveImport @@ -349,9 +349,10 @@ ] --- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified -icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt) +-- | Get the NamePprCtx function based on the flags and this InteractiveContext +icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx +icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) + where ptc = initPromotionTickContext (ic_dflags ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. By putting new things first, unqualified @@ -441,7 +442,7 @@ _ -> False is_sub_bndr _ = False -substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | isEmptyTCvSubst subst = ictxt | otherwise = ictxt { ic_tythings = map subst_ty tts } diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -113,6 +113,11 @@ #if defined(mingw32_HOST_OS) import Foreign.C import GHC.IO.Handle.FD (fdToHandle) +# if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +# endif #else import System.Posix as Posix #endif @@ -195,7 +200,7 @@ InternalInterp -> run msg -- Just run it directly #endif ExternalInterp c i -> withIServ_ c i $ \iserv -> - uninterruptibleMask_ $ -- Note [uninterruptibleMask_] + uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd] iservCall iserv msg @@ -606,7 +611,9 @@ foreign import ccall unsafe "io.h _get_osfhandle" _get_osfhandle :: CInt -> IO CInt -runWithPipes createProc prog opts = do +runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesPOSIX createProc prog opts = do (rfd1, wfd1) <- createPipeFd -- we read on rfd1 (rfd2, wfd2) <- createPipeFd -- we write on wfd2 wh_client <- _get_osfhandle wfd1 @@ -619,6 +626,27 @@ where mkHandle :: CInt -> IO Handle mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) +# if defined (__IO_MANAGER_WINIO__) +runWithPipesNative :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesNative createProc prog opts = do + (rh, wfd1) <- createPipe -- we read on rfd1 + (rfd2, wh) <- createPipe -- we write on wfd2 + wh_client <- handleToHANDLE wfd1 + rh_client <- handleToHANDLE rfd2 + -- Associate the handle with the current manager + -- but don't touch the ones we're passing to the child + -- since it needs to register the handle with its own manager. + associateHandle' =<< handleToHANDLE rh + associateHandle' =<< handleToHANDLE wh + let args = show wh_client : show rh_client : opts + ph <- createProc (proc prog args) + return (ph, rh, wh) + +runWithPipes = runWithPipesPOSIX runWithPipesNative +# else +runWithPipes = runWithPipesPOSIX +# endif #else runWithPipes createProc prog opts = do (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 @@ -724,7 +752,7 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- homeModInfoByteCode hmi, [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -18,7 +18,6 @@ , sTopDir , sGlobalPackageDatabasePath , sLdSupportsCompactUnwind - , sLdSupportsBuildId , sLdSupportsFilelist , sLdIsGnuLd , sGccSupportsNoPie @@ -35,7 +34,6 @@ , sPgm_dll , sPgm_T , sPgm_windres - , sPgm_libtool , sPgm_ar , sPgm_otool , sPgm_install_name_tool @@ -88,7 +86,6 @@ -- platform-specific and platform-agnostic. data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool - , toolSettings_ldSupportsBuildId :: Bool , toolSettings_ldSupportsFilelist :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool @@ -110,7 +107,6 @@ , toolSettings_pgm_dll :: (String, [Option]) , toolSettings_pgm_T :: String , toolSettings_pgm_windres :: String - , toolSettings_pgm_libtool :: String , toolSettings_pgm_ar :: String , toolSettings_pgm_otool :: String , toolSettings_pgm_install_name_tool :: String @@ -171,7 +167,7 @@ dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver ----------------------------------------------------------------------------- --- Accessessors from 'Settings' +-- Accessors from 'Settings' sProgramName :: Settings -> String sProgramName = ghcNameVersion_programName . sGhcNameVersion @@ -191,8 +187,6 @@ sLdSupportsCompactUnwind :: Settings -> Bool sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings -sLdSupportsBuildId :: Settings -> Bool -sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings sLdIsGnuLd :: Settings -> Bool @@ -226,8 +220,6 @@ sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings -sPgm_libtool :: Settings -> String -sPgm_libtool = toolSettings_pgm_libtool . sToolSettings sPgm_ar :: Settings -> String sPgm_ar = toolSettings_pgm_ar . sToolSettings sPgm_otool :: Settings -> String diff --git a/compiler/GHC/Settings/Constants.hs b/compiler/GHC/Settings/Constants.hs --- a/compiler/GHC/Settings/Constants.hs +++ b/compiler/GHC/Settings/Constants.hs @@ -17,8 +17,8 @@ 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/Syntax.hs b/compiler/GHC/Stg/Syntax.hs --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -61,7 +61,7 @@ -- ppr StgPprOpts(..), panicStgPprOpts, shortStgPprOpts, - pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, pprStgAlt, pprGenStgTopBinding, pprStgTopBinding, pprGenStgTopBindings, pprStgTopBindings ) where @@ -236,7 +236,7 @@ -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -882,7 +882,7 @@ 4 (pprStgExpr opts body) StgRhsCon cc con mid _ticks args - -> hcat [ ppr cc, space + -> hcat [ if stgSccEnabled opts then ppr cc <> space else empty , case mid of NoNumber -> empty Numbered n -> hcat [ppr n, space] diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs --- a/compiler/GHC/StgToCmm/Config.hs +++ b/compiler/GHC/StgToCmm/Config.hs @@ -22,8 +22,8 @@ -- Cmm/Parser.y which preloads it with a panic , stgToCmmTmpDir :: !TempDir -- ^ Temp Dir for files used in compilation , stgToCmmContext :: !SDocContext -- ^ Context for StgToCmm phase - , stgToCmmDebugLevel :: !Int -- ^ The verbosity of debug messages - , stgToCmmBinBlobThresh :: !(Maybe Word) -- ^ Threshold at which Binary literals (e.g. strings) + , stgToCmmEmitDebugInfo :: !Bool -- ^ Whether we wish to output debug information + , stgToCmmBinBlobThresh :: !(Maybe Word) -- ^ Threshold at which Binary literals (e.g. strings) -- are either dumped to a file and a CmmFileEmbed literal -- is emitted (over threshold), or become a CmmString -- Literal (under or at threshold). CmmFileEmbed is only supported @@ -66,7 +66,6 @@ , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction - , stgToCmmAllowFabsInstrs :: !Bool -- ^ Allowed to generate Fabs instructions , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs --- a/compiler/GHC/StgToCmm/Types.hs +++ b/compiler/GHC/StgToCmm/Types.hs @@ -70,52 +70,6 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have -fomit-interface-pragmas or -fno-code; and we won't read it in if you have -fignore-interface-pragmas. (We could revisit this decision.) - -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in `Note [Conveying CAF-info and LFInfo between modules]`, -imported unlifted nullary datacons must have their LambdaFormInfo set to -reflect the fact that they are evaluated . This is necessary as otherwise -references to them may be passed untagged to code that expects tagged -references. - -What may be less obvious is that this must be done for not only datacon -workers but also *wrappers*. The reason is found in this program -from #23146: - - module B where - - type NP :: [UnliftedType] -> UnliftedType - data NP xs where - UNil :: NP '[] - - - module A where - import B - - fieldsSam :: NP xs -> NP xs -> Bool - fieldsSam UNil UNil = True - - x = fieldsSam UNil UNil - -Due to its GADT nature, `B.UNil` produces a trivial wrapper - - $WUNil :: NP '[] - $WUNil = UNil @'[] @~() - -which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the -correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged -pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage -of the unlifted nature of its arguments by omitting handling of the zero -tag when scrutinising them. - -The fix is straightforward: extend the logic in `mkLFImported` to cover -(nullary) datacon wrappers as well as workers. This is safe because we -know that the wrapper of a nullary datacon will be in WHNF, even if it -includes equalities evidence (since such equalities are not runtime -relevant). This fixed #23146. - -See also Note [The LFInfo of Imported Ids] -} -- | Codegen-generated Id infos, to be passed to downstream via interfaces. @@ -164,7 +118,7 @@ !StandardFormInfo !Bool -- True <=> *might* be a function type - | LFCon -- A saturated data constructor application + | LFCon -- A saturated constructor application !DataCon -- The constructor | LFUnknown -- Used for function arguments and imported things. diff --git a/compiler/GHC/SysTools/BaseDir.hs b/compiler/GHC/SysTools/BaseDir.hs --- a/compiler/GHC/SysTools/BaseDir.hs +++ b/compiler/GHC/SysTools/BaseDir.hs @@ -55,13 +55,10 @@ Note [tooldir: How GHC finds mingw on Windows] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC has some custom logic on Windows for finding the mingw -toolchain and perl. Depending on whether GHC is built -with the make build system or Hadrian, and on whether we're -running a bindist, we might find the mingw toolchain -either under $topdir/../{mingw, perl}/ or -$topdir/../../{mingw, perl}/. +toolchain. In general we will find the mingw toolchain +in $topdir/../../mingw/. -This story is long and with lots of twist and turns.. But lets talk about how +This story is long and with lots of twist and turns.. But let's talk about how the build system finds and wires through the toolchain information. 1) It all starts in configure.ac which has two modes it operates on: @@ -90,25 +87,11 @@ From `aclocal.m4` we export a couple of variables starting with `Settings` which will be used to generate the settings file. -3) The next step is to generate the settings file, this is where things diverge - based on the build system. Both Make and Hadrian handle this differently: - -make) - Make deals with this rather simply. As an output of configure.ac - `config.mk.in` is processed and `config.mk` generated which has the values we - set in `aclocal.m4`. This allows the rest of the build system to have access - to these and other values determined by configure. - - Based on this file, `rts/include/ghc.mk` when ran will produce the settings file - by echoing the values into a the final file. Coincidentally this is also - where `ghcplatform.h` and `ghcversion.h` generated which contains information - about the build platform and sets CPP for use by the entire build. - -hadrian) - For hadrian the file `cfg/system.config.in` is preprocessed by configure and - the output written to `system.config`. This serves the same purpose as - `config.mk` but it rewrites the values that were exported. As an example - `SettingsCCompilerCommand` is rewritten to `settings-c-compiler-command`. +3) The next step is to generate the settings file: The file + `cfg/system.config.in` is preprocessed by configure and the output written to + `system.config`. This serves the same purpose as `config.mk` but it rewrites + the values that were exported. As an example `SettingsCCompilerCommand` is + rewritten to `settings-c-compiler-command`. Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to the settings `keys` in the `system.config`. As an example, @@ -139,7 +122,7 @@ -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir - :: Bool -- ^ whether we are use the ambiant mingw toolchain + :: Bool -- ^ whether we use the ambient mingw toolchain -> Maybe FilePath -- ^ tooldir -> String -> String #if defined(mingw32_HOST_OS) @@ -183,7 +166,7 @@ -- tooldir can't be located, or returns @Just tooldirpath@. -- If the distro toolchain is being used we treat Windows the same as Linux findToolDir - :: Bool -- ^ whether we are use the ambiant mingw toolchain + :: Bool -- ^ whether we use the ambient mingw toolchain -> FilePath -- ^ topdir -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) diff --git a/compiler/GHC/SysTools/Terminal.hs b/compiler/GHC/SysTools/Terminal.hs --- a/compiler/GHC/SysTools/Terminal.hs +++ b/compiler/GHC/SysTools/Terminal.hs @@ -4,16 +4,12 @@ import GHC.Prelude -#if defined(MIN_VERSION_terminfo) -import GHC.IO (catchException) -import Data.Maybe (fromMaybe) -import System.Console.Terminfo (SetupTermError, Terminal, getCapability, - setupTermFromEnv, termColors) -import System.Posix (queryTerminal, stdError) -#elif defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) +import System.Environment (lookupEnv) +import System.IO (hIsTerminalDevice, stderr) +#else import GHC.IO (catchException) import GHC.Utils.Exception (try) --- import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32 import qualified System.Win32 as Win32 @@ -40,18 +36,12 @@ -- | Check if ANSI escape sequences can be used to control color in stderr. stderrSupportsAnsiColors' :: IO Bool stderrSupportsAnsiColors' = do -#if defined(MIN_VERSION_terminfo) - stderr_available <- queryTerminal stdError - if stderr_available then - fmap termSupportsColors setupTermFromEnv - `catchException` \ (_ :: SetupTermError) -> pure False - else - pure False - where - termSupportsColors :: Terminal -> Bool - termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 - -#elif defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) + -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI + isTerminal <- hIsTerminalDevice stderr + term <- lookupEnv "TERM" + pure $ isTerminal && term /= Just "dumb" +#else h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE `catchException` \ (_ :: IOError) -> pure Win32.nullHANDLE @@ -100,6 +90,4 @@ foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL -#else - pure False #endif diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -2,3140 +2,4103 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage - -module GHC.Tc.Errors.Ppr - ( pprTypeDoesNotHaveFixedRuntimeRep - , pprScopeError - -- - , tidySkolemInfo - , tidySkolemInfoAnon - -- - , withHsDocContext - , pprHsDocContext - , inHsDocContext - ) - where - -import GHC.Prelude - -import GHC.Builtin.Names - -import GHC.Core.Coercion -import GHC.Core.Unify ( tcMatchTys ) -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch) -import GHC.Core.ConLike -import GHC.Core.FamInstEnv (famInstAxiom) -import GHC.Core.InstEnv -import GHC.Core.TyCo.Rep (Type(..)) -import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE) -import GHC.Core.PatSyn ( patSynName, pprPatSynType ) -import GHC.Core.Predicate -import GHC.Core.Type - -import GHC.Driver.Flags - -import GHC.Hs - -import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint -import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc) -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Utils.TcType -import GHC.Types.Error -import GHC.Types.FieldLabel (flIsOverloaded) -import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) -import GHC.Types.Hint.Ppr () -- Outputable GhcHint -import GHC.Types.Basic -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance - , RdrName, rdrNameOcc, greMangledName ) -import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.TyThing -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env - -import GHC.Unit.State (pprWithUnitState, UnitState) -import GHC.Unit.Module - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Data.List.SetOps ( nubOrdBy ) -import GHC.Data.Maybe -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import qualified GHC.LanguageExtensions as LangExt - -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Function (on) -import Data.List ( groupBy, sortBy, tails - , partition, unfoldr ) -import Data.Ord ( comparing ) -import Data.Bifunctor -import GHC.Types.Name.Env - - -instance Diagnostic TcRnMessage where - diagnosticMessage = \case - TcRnUnknownMessage m - -> diagnosticMessage m - TcRnMessageWithInfo unit_state msg_with_info - -> case msg_with_info of - TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) - TcRnSolverReport msgs _ _ - -> mkDecorated $ - map pprSolverReportWithCtxt msgs - TcRnRedundantConstraints redundants (info, show_info) - -> mkSimpleDecorated $ - text "Redundant constraint" <> plural redundants <> colon - <+> pprEvVarTheta redundants - $$ if show_info then text "In" <+> ppr info else empty - TcRnInaccessibleCode implic contras - -> mkSimpleDecorated $ - hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - $$ vcat (map pprSolverReportWithCtxt (NE.toList contras)) - TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) - -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] - TcRnImplicitLift id_or_name ErrInfo{..} - -> mkDecorated $ - ( text "The variable" <+> quotes (ppr id_or_name) <+> - text "is implicitly lifted in the TH quotation" - ) : [errInfoContext, errInfoSupplementary] - TcRnUnusedPatternBinds bind - -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] - TcRnDodgyImports name - -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)] - TcRnDodgyExports name - -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)] - TcRnMissingImportList ie - -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> - text "does not have an explicit import list" - ] - TcRnUnsafeDueToPlugin - -> mkDecorated [text "Use of plugins makes the module unsafe"] - TcRnModMissingRealSrcSpan mod - -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod] - TcRnIdNotExportedFromModuleSig name mod - -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> - text "does not exist in the signature for" <+> ppr mod - ] - TcRnIdNotExportedFromLocalSig name - -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> - text "does not exist in the local signature." - ] - TcRnShadowedName occ provenance - -> let shadowed_locs = case provenance of - ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n] - ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres - in mkSimpleDecorated $ - sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] - TcRnDuplicateWarningDecls d rdr_name - -> mkSimpleDecorated $ - vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLocA d)] - TcRnSimplifierTooManyIterations simples limit wc - -> mkSimpleDecorated $ - hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , text "Simples:" <+> ppr simples - ]) - TcRnIllegalPatSynDecl rdrname - -> mkSimpleDecorated $ - hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") - TcRnLinearPatSyn ty - -> mkSimpleDecorated $ - hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty) - TcRnEmptyRecordUpdate - -> mkSimpleDecorated $ text "Empty record update" - TcRnIllegalFieldPunning fld - -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) - TcRnIllegalWildcardsInRecord fld_part - -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part - TcRnIllegalWildcardInType mb_name bad mb_ctxt - -> mkSimpleDecorated $ vcat [ main_msg, context_msg ] - where - main_msg :: SDoc - main_msg = case bad of - WildcardNotLastInConstraint -> - hang notAllowed 2 constraint_hint_msg - ExtraConstraintWildcardNotAllowed allow_sole -> - case allow_sole of - SoleExtraConstraintWildcardNotAllowed -> - notAllowed - SoleExtraConstraintWildcardAllowed -> - hang notAllowed 2 sole_msg - WildcardsNotAllowedAtAll -> - notAllowed - context_msg :: SDoc - context_msg = case mb_ctxt of - Just ctxt -> nest 2 (text "in" <+> pprHsDocContext ctxt) - _ -> empty - notAllowed, what, wildcard, how :: SDoc - notAllowed = what <+> quotes wildcard <+> how - wildcard = case mb_name of - Nothing -> pprAnonWildCard - Just name -> ppr name - what - | Just _ <- mb_name - = text "Named wildcard" - | ExtraConstraintWildcardNotAllowed {} <- bad - = text "Extra-constraint wildcard" - | otherwise - = text "Wildcard" - how = case bad of - WildcardNotLastInConstraint - -> text "not allowed in a constraint" - _ -> text "not allowed" - constraint_hint_msg :: SDoc - constraint_hint_msg - | Just _ <- mb_name - = vcat [ text "Extra-constraint wildcards must be anonymous" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - | otherwise - = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - sole_msg :: SDoc - sole_msg = - vcat [ text "except as the sole constraint" - , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] - TcRnDuplicateFieldName fld_part dups - -> mkSimpleDecorated $ - hsep [text "duplicate field name", - quotes (ppr (NE.head dups)), - text "in record", pprRecordFieldPart fld_part] - TcRnIllegalViewPattern pat - -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] - TcRnCharLiteralOutOfRange c - -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' - TcRnIllegalWildcardsInConstructor con - -> mkSimpleDecorated $ - vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "The constructor has no labelled fields") ] - TcRnIgnoringAnnotations anns - -> mkSimpleDecorated $ - text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" - TcRnAnnotationInSafeHaskell - -> mkSimpleDecorated $ - vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] - TcRnInvalidTypeApplication fun_ty hs_ty - -> mkSimpleDecorated $ - text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ - text "to a visible type argument" <+> quotes (ppr hs_ty) - TcRnTagToEnumMissingValArg - -> mkSimpleDecorated $ - text "tagToEnum# must appear applied to one value argument" - TcRnTagToEnumUnspecifiedResTy ty - -> mkSimpleDecorated $ - hang (text "Bad call to tagToEnum# at type" <+> ppr ty) - 2 (vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ]) - TcRnTagToEnumResTyNotAnEnum ty - -> mkSimpleDecorated $ - hang (text "Bad call to tagToEnum# at type" <+> ppr ty) - 2 (text "Result type must be an enumeration type") - TcRnArrowIfThenElsePredDependsOnResultTy - -> mkSimpleDecorated $ - text "Predicate type of `ifThenElse' depends on result type" - TcRnIllegalHsBootFileDecl - -> mkSimpleDecorated $ - text "Illegal declarations in an hs-boot file" - TcRnRecursivePatternSynonym binds - -> mkSimpleDecorated $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) - <+> pprLoc (locA loc) - TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty - -> mkSimpleDecorated $ - hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) - TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty - -> mkSimpleDecorated $ - hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (vcat [ hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) - , extra ]) - where - extra | Just rhs_ty <- m_unif_ty - = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] - | otherwise - = empty - TcRnMissingSignature what _ _ -> - mkSimpleDecorated $ - case what of - MissingPatSynSig p -> - hang (text "Pattern synonym with no type signature:") - 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) - MissingTopLevelBindingSig name ty -> - hang (text "Top-level binding with no type signature:") - 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) - MissingTyConKindSig tc cusks_enabled -> - hang msg - 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) - where - msg | cusks_enabled - = text "Top-level type constructor with no standalone kind signature or CUSK:" - | otherwise - = text "Top-level type constructor with no standalone kind signature:" - - TcRnPolymorphicBinderMissingSig n ty - -> mkSimpleDecorated $ - sep [ text "Polymorphic local binding with no type signature:" - , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] - TcRnOverloadedSig sig - -> mkSimpleDecorated $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr sig) - TcRnTupleConstraintInst _ - -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint" - TcRnAbstractClassInst clas - -> mkSimpleDecorated $ - text "Cannot define instance for abstract class" <+> - quotes (ppr (className clas)) - TcRnNoClassInstHead tau - -> mkSimpleDecorated $ - hang (text "Instance head is not headed by a class:") 2 (pprType tau) - TcRnUserTypeError ty - -> mkSimpleDecorated (pprUserTypeErrorTy ty) - TcRnConstraintInKind ty - -> mkSimpleDecorated $ - text "Illegal constraint in a kind:" <+> pprType ty - TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty - -> mkSimpleDecorated $ - sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:" - , pprType ty ] - where - what = case tuple_or_sum of - UnboxedTupleType -> text "tuple" - UnboxedSumType -> text "sum" - TcRnLinearFuncInKind ty - -> mkSimpleDecorated $ - text "Illegal linear function in a kind:" <+> pprType ty - TcRnForAllEscapeError ty kind - -> mkSimpleDecorated $ vcat - [ hang (text "Quantified type's kind mentions quantified type variable") - 2 (text "type:" <+> quotes (ppr ty)) - , hang (text "where the body of the forall has this kind:") - 2 (quotes (pprKind kind)) ] - TcRnVDQInTermType ty - -> mkSimpleDecorated $ vcat - [ hang (text "Illegal visible, dependent quantification" <+> - text "in the type of a term:") - 2 (pprType ty) - , text "(GHC does not yet support this)" ] - TcRnBadQuantPredHead ty - -> mkSimpleDecorated $ - hang (text "Quantified predicate must have a class or type variable head:") - 2 (pprType ty) - TcRnIllegalTupleConstraint ty - -> mkSimpleDecorated $ - text "Illegal tuple constraint:" <+> pprType ty - TcRnNonTypeVarArgInConstraint ty - -> mkSimpleDecorated $ - hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> pprType ty) - TcRnIllegalImplicitParam ty - -> mkSimpleDecorated $ - text "Illegal implicit parameter" <+> quotes (pprType ty) - TcRnIllegalConstraintSynonymOfKind kind - -> mkSimpleDecorated $ - text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind) - TcRnIllegalClassInst tcf - -> mkSimpleDecorated $ - vcat [ text "Illegal instance for a" <+> ppr tcf - , text "A class instance must be for a class" ] - TcRnOversaturatedVisibleKindArg ty - -> mkSimpleDecorated $ - text "Illegal oversaturated visible kind argument:" <+> - quotes (char '@' <> pprParendType ty) - TcRnBadAssociatedType clas tc - -> mkSimpleDecorated $ - hsep [ text "Class", quotes (ppr clas) - , text "does not have an associated type", quotes (ppr tc) ] - TcRnForAllRankErr rank ty - -> let herald = case tcSplitForAllTyVars ty of - ([], _) -> text "Illegal qualified type:" - _ -> text "Illegal polymorphic type:" - extra = case rank of - MonoTypeConstraint -> text "A constraint must be a monotype" - _ -> empty - in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra] - TcRnMonomorphicBindings bindings - -> let pp_bndrs = pprBindings bindings - in mkSimpleDecorated $ - sep [ text "The Monomorphism Restriction applies to the binding" - <> plural bindings - , text "for" <+> pp_bndrs ] - TcRnOrphanInstance inst - -> mkSimpleDecorated $ - hsep [ text "Orphan instance:" - , pprInstanceHdr inst - ] - TcRnFunDepConflict unit_state sorted - -> let herald = text "Functional dependencies conflict between instance declarations:" - in mkSimpleDecorated $ - pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) - TcRnDupInstanceDecls unit_state sorted - -> let herald = text "Duplicate instance declarations:" - in mkSimpleDecorated $ - pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) - TcRnConflictingFamInstDecls sortedNE - -> let sorted = NE.toList sortedNE - in mkSimpleDecorated $ - hang (text "Conflicting family instance declarations:") - 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) - | fi <- sorted - , let ax = famInstAxiom fi ]) - TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns) - -> let (herald, show_kinds) = case rea of - InjErrRhsBareTyVar tys -> - (injectivityErrorHerald $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys, False) - InjErrRhsCannotBeATypeFam -> - (injectivityErrorHerald $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:", False) - InjErrRhsOverlap -> - (text "Type family equation right-hand sides overlap; this violates" $$ - text "the family's injectivity annotation:", False) - InjErrCannotInferFromRhs tvs has_kinds _ -> - let show_kinds = has_kinds == YesHasKinds - what = if show_kinds then text "Type/kind" else text "Type" - body = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) - , text "cannot be inferred from the right-hand side." ] - in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) - - in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $ - hang herald - 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) - TcRnBangOnUnliftedType ty - -> mkSimpleDecorated $ - text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) - TcRnMultipleDefaultDeclarations dup_things - -> mkSimpleDecorated $ - hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp :: LDefaultDecl GhcRn -> SDoc - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr (locA locn) - TcRnBadDefaultType ty deflt_clss - -> mkSimpleDecorated $ - hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) - TcRnPatSynBundledWithNonDataCon - -> mkSimpleDecorated $ - text "Pattern synonyms can be bundled only with datatypes." - TcRnPatSynBundledWithWrongType expected_res_ty res_ty - -> mkSimpleDecorated $ - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - TcRnDupeModuleExport mod - -> mkSimpleDecorated $ - hsep [ text "Duplicate" - , quotes (text "Module" <+> ppr mod) - , text "in export list" ] - TcRnExportedModNotImported mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "is not imported" - TcRnNullExportedModule mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "exports nothing" - TcRnMissingExportList mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "is missing an export list" - TcRnExportHiddenComponents export_item - -> mkSimpleDecorated - $ formatExportItemError - (ppr export_item) - "attempts to export constructors or class methods that are not visible here" - TcRnDuplicateExport child ie1 ie2 - -> mkSimpleDecorated $ - hsep [ quotes (ppr child) - , text "is exported by", quotes (ppr ie1) - , text "and", quotes (ppr ie2) ] - TcRnExportedParentChildMismatch parent_name ty_thing child parent_names - -> mkSimpleDecorated $ - text "The type constructor" <+> quotes (ppr parent_name) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) - where - pp_category :: TyThing -> String - pp_category (AnId i) - | isRecordSelector i = "record selector" - pp_category i = tyThingCategory i - what_is = pp_category ty_thing - thing = ppr child - parents = map ppr parent_names - TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2 - -> mkSimpleDecorated $ - vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export child1 gre1 ie1 - , ppr_export child2 gre2 ie2 - ] - where - ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name child)) - 2 (pprNameProvenance gre)) - - -- DuplicateRecordFields means that nameOccName might be a - -- mangled $sel-prefixed thing, in which case show the correct OccName - -- alone (but otherwise show the Name so it will have a module - -- qualifier) - ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl - | otherwise = ppr (flSelector fl) - ppr_name (NormalGreName name) = ppr name - TcRnAmbiguousField rupd parent_type - -> mkSimpleDecorated $ - vcat [ text "The record update" <+> ppr rupd - <+> text "with type" <+> ppr parent_type - <+> text "is ambiguous." - , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." - ] - TcRnMissingFields con fields - -> mkSimpleDecorated $ vcat [header, nest 2 rest] - where - rest | null fields = empty - | otherwise = vcat (fmap pprField fields) - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" <> - if null fields then empty else colon - TcRnFieldUpdateInvalidType prs - -> mkSimpleDecorated $ - hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - TcRnNoConstructorHasAllFields conflictingFields - -> mkSimpleDecorated $ - hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels - -> mkSimpleDecorated $ - text "Cannot use a mixture of pattern synonym and record selectors" $$ - text "Record selectors defined by" - <+> quotes (ppr data_name) - <> colon - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr pat_name) - <> colon - <+> pprWithCommas ppr pat_syn_sels - TcRnMissingStrictFields con fields - -> mkSimpleDecorated $ vcat [header, nest 2 rest] - where - rest | null fields = empty -- Happens for non-record constructors - -- with strict fields - | otherwise = vcat (fmap pprField fields) - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" <> - if null fields then empty else colon - TcRnNoPossibleParentForFields rbinds - -> mkSimpleDecorated $ - hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where fields = map (hfbLHS . unLoc) rbinds - TcRnBadOverloadedRecordUpdate _rbinds - -> mkSimpleDecorated $ - text "Record update is ambiguous, and requires a type signature" - TcRnStaticFormNotClosed name reason - -> mkSimpleDecorated $ - quotes (ppr name) - <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ sep (causes reason) - where - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - TcRnUselessTypeable - -> mkSimpleDecorated $ - text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" - TcRnDerivingDefaults cls - -> mkSimpleDecorated $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - ] - TcRnNonUnaryTypeclassConstraint ct - -> mkSimpleDecorated $ - quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - TcRnPartialTypeSignatures _ theta - -> mkSimpleDecorated $ - text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason - -> mkSimpleDecorated $ - derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason - TcRnLazyGADTPattern - -> mkSimpleDecorated $ - hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - TcRnArrowProcGADTPattern - -> mkSimpleDecorated $ - text "Proc patterns cannot use existential or GADT data constructors" - - TcRnSpecialClassInst cls because_safeHaskell - -> mkSimpleDecorated $ - text "Class" <+> quotes (ppr $ className cls) - <+> text "does not support user-specified instances" - <> safeHaskell_msg - where - safeHaskell_msg - | because_safeHaskell - = text " when Safe Haskell is enabled." - | otherwise - = dot - TcRnForallIdentifier rdr_name - -> mkSimpleDecorated $ - fsep [ text "The use of" <+> quotes (ppr rdr_name) - <+> text "as an identifier", - text "will become an error in a future GHC release." ] - TcRnTypeEqualityOutOfScope - -> mkDecorated - [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$ - text "Assuming it to stand for an equality constraint." - , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$ - text "exported from Data.Type.Equality and Prelude.") $$ - text "If you are using a custom Prelude, consider re-exporting it." - , text "This will become an error in a future GHC release." ] - TcRnTypeEqualityRequiresOperators - -> mkSimpleDecorated $ - fsep [ text "The use of" <+> quotes (text "~") - <+> text "without TypeOperators", - text "will become an error in a future GHC release." ] - TcRnIllegalTypeOperator overall_ty op - -> mkSimpleDecorated $ - text "Illegal operator" <+> quotes (ppr op) <+> - text "in type" <+> quotes (ppr overall_ty) - TcRnGADTMonoLocalBinds - -> mkSimpleDecorated $ - fsep [ text "Pattern matching on GADTs without MonoLocalBinds" - , text "is fragile." ] - TcRnIncorrectNameSpace name _ - -> mkSimpleDecorated $ msg - where - msg - -- We are in a type-level namespace, - -- and the name is incorrectly at the term-level. - | isValNameSpace ns - = text "The" <+> what <+> text "does not live in the type-level namespace" - - -- We are in a term-level namespace, - -- and the name is incorrectly at the type-level. - | otherwise - = text "Illegal term-level use of the" <+> what - ns = nameNameSpace name - what = pprNameSpace ns <+> quotes (ppr name) - TcRnNotInScope err name imp_errs _ - -> mkSimpleDecorated $ - pprScopeError name err $$ vcat (map ppr imp_errs) - TcRnUntickedPromotedThing thing - -> mkSimpleDecorated $ - text "Unticked promoted" <+> what - where - what :: SDoc - what = case thing of - UntickedExplicitList -> text "list" <> dot - UntickedConstructor fixity nm -> - let con = pprUntickedConstructor fixity nm - bare_sym = isBareSymbol fixity nm - in text "constructor:" <+> con <> if bare_sym then empty else dot - TcRnIllegalBuiltinSyntax what rdr_name - -> mkSimpleDecorated $ - hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name] - TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty - -> mkSimpleDecorated $ - hang (hsep $ [ text "Defaulting" ] - ++ - (case tidy_tv of - Nothing -> [] - Just tv -> [text "the type variable" - , quotes (ppr tv)]) - ++ - [ text "to type" - , quotes (ppr default_ty) - , text "in the following constraint" <> plural tidy_wanteds ]) - 2 - (pprWithArising tidy_wanteds) - - - TcRnForeignImportPrimExtNotSet _decl - -> mkSimpleDecorated $ - text "`foreign import prim' requires GHCForeignImportPrim." - - TcRnForeignImportPrimSafeAnn _decl - -> mkSimpleDecorated $ - text "The safe/unsafe annotation should not be used with `foreign import prim'." - - TcRnForeignFunctionImportAsValue _decl - -> mkSimpleDecorated $ - text "`value' imports cannot have function types" - - TcRnFunPtrImportWithoutAmpersand _decl - -> mkSimpleDecorated $ - text "possible missing & in foreign import of FunPtr" - - TcRnIllegalForeignDeclBackend _decl _backend expectedBknds - -> mkSimpleDecorated $ text "Illegal foreign declaration:" <+> - case expectedBknds of - COrAsmOrLlvm -> - text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)" - COrAsmOrLlvmOrInterp -> - text "requires interpreted, unregisterised, llvm or native code generation" - - TcRnUnsupportedCallConv _decl unsupportedCC - -> mkSimpleDecorated $ - case unsupportedCC of - StdCallConvUnsupported -> - text "the 'stdcall' calling convention is unsupported on this platform," - $$ text "treating as ccall" - PrimCallConvUnsupported -> - text "The `prim' calling convention can only be used with `foreign import'" - JavaScriptCallConvUnsupported -> - text "The `javascript' calling convention is unsupported on this platform" - - TcRnIllegalForeignType mArgOrResult reason - -> mkSimpleDecorated $ hang msg 2 extra - where - arg_or_res = case mArgOrResult of - Nothing -> empty - Just Arg -> text "argument" - Just Result -> text "result" - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - extra = - case reason of - TypeCannotBeMarshaled ty why -> - let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" - in case why of - NotADataType -> - quotes (ppr ty) <+> text "is not a data type" - NewtypeDataConNotInScope Nothing -> - hang innerMsg 2 $ text "because its data constructor is not in scope" - NewtypeDataConNotInScope (Just tc) -> - hang innerMsg 2 $ - text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - UnliftedFFITypesNeeded -> - innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types" - NotABoxedMarshalableTyCon -> innerMsg - ForeignLabelNotAPtr -> - innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" - NotSimpleUnliftedType -> - innerMsg $$ text "foreign import prim only accepts simple unlifted types" - ForeignDynNotPtr expected ty -> - vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] - SafeHaskellMustBeInIO -> - text "Safe Haskell is on, all FFI imports must be in the IO monad" - IOResultExpected -> - text "IO result type expected" - UnexpectedNestedForall -> - text "Unexpected nested forall" - LinearTypesNotAllowed -> - text "Linear types are not supported in FFI declarations, see #18472" - OneArgExpected -> - text "One argument expected" - AtLeastOneArgExpected -> - text "At least one argument expected" - TcRnInvalidCIdentifier target - -> mkSimpleDecorated $ - sep [quotes (ppr target) <+> text "is not a valid C identifier"] - TcRnCannotDefaultConcrete frr - -> mkSimpleDecorated $ - ppr (frr_context frr) $$ - text "cannot be assigned a fixed runtime representation," <+> - text "not even by defaulting." - - diagnosticReason = \case - TcRnUnknownMessage m - -> diagnosticReason m - TcRnMessageWithInfo _ msg_with_info - -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticReason m - TcRnSolverReport _ reason _ - -> reason -- Error, or a Warning if we are deferring type errors - TcRnRedundantConstraints {} - -> WarningWithFlag Opt_WarnRedundantConstraints - TcRnInaccessibleCode {} - -> WarningWithFlag Opt_WarnInaccessibleCode - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> ErrorWithoutFlag - TcRnImplicitLift{} - -> WarningWithFlag Opt_WarnImplicitLift - TcRnUnusedPatternBinds{} - -> WarningWithFlag Opt_WarnUnusedPatternBinds - TcRnDodgyImports{} - -> WarningWithFlag Opt_WarnDodgyImports - TcRnDodgyExports{} - -> WarningWithFlag Opt_WarnDodgyExports - TcRnMissingImportList{} - -> WarningWithFlag Opt_WarnMissingImportList - TcRnUnsafeDueToPlugin{} - -> WarningWithoutFlag - TcRnModMissingRealSrcSpan{} - -> ErrorWithoutFlag - TcRnIdNotExportedFromModuleSig{} - -> ErrorWithoutFlag - TcRnIdNotExportedFromLocalSig{} - -> ErrorWithoutFlag - TcRnShadowedName{} - -> WarningWithFlag Opt_WarnNameShadowing - TcRnDuplicateWarningDecls{} - -> ErrorWithoutFlag - TcRnSimplifierTooManyIterations{} - -> ErrorWithoutFlag - TcRnIllegalPatSynDecl{} - -> ErrorWithoutFlag - TcRnLinearPatSyn{} - -> ErrorWithoutFlag - TcRnEmptyRecordUpdate - -> ErrorWithoutFlag - TcRnIllegalFieldPunning{} - -> ErrorWithoutFlag - TcRnIllegalWildcardsInRecord{} - -> ErrorWithoutFlag - TcRnIllegalWildcardInType{} - -> ErrorWithoutFlag - TcRnDuplicateFieldName{} - -> ErrorWithoutFlag - TcRnIllegalViewPattern{} - -> ErrorWithoutFlag - TcRnCharLiteralOutOfRange{} - -> ErrorWithoutFlag - TcRnIllegalWildcardsInConstructor{} - -> ErrorWithoutFlag - TcRnIgnoringAnnotations{} - -> WarningWithoutFlag - TcRnAnnotationInSafeHaskell - -> ErrorWithoutFlag - TcRnInvalidTypeApplication{} - -> ErrorWithoutFlag - TcRnTagToEnumMissingValArg - -> ErrorWithoutFlag - TcRnTagToEnumUnspecifiedResTy{} - -> ErrorWithoutFlag - TcRnTagToEnumResTyNotAnEnum{} - -> ErrorWithoutFlag - TcRnArrowIfThenElsePredDependsOnResultTy - -> ErrorWithoutFlag - TcRnIllegalHsBootFileDecl - -> ErrorWithoutFlag - TcRnRecursivePatternSynonym{} - -> ErrorWithoutFlag - TcRnPartialTypeSigTyVarMismatch{} - -> ErrorWithoutFlag - TcRnPartialTypeSigBadQuantifier{} - -> ErrorWithoutFlag - TcRnMissingSignature what exported overridden - -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden - TcRnPolymorphicBinderMissingSig{} - -> WarningWithFlag Opt_WarnMissingLocalSignatures - TcRnOverloadedSig{} - -> ErrorWithoutFlag - TcRnTupleConstraintInst{} - -> ErrorWithoutFlag - TcRnAbstractClassInst{} - -> ErrorWithoutFlag - TcRnNoClassInstHead{} - -> ErrorWithoutFlag - TcRnUserTypeError{} - -> ErrorWithoutFlag - TcRnConstraintInKind{} - -> ErrorWithoutFlag - TcRnUnboxedTupleOrSumTypeFuncArg{} - -> ErrorWithoutFlag - TcRnLinearFuncInKind{} - -> ErrorWithoutFlag - TcRnForAllEscapeError{} - -> ErrorWithoutFlag - TcRnVDQInTermType{} - -> ErrorWithoutFlag - TcRnBadQuantPredHead{} - -> ErrorWithoutFlag - TcRnIllegalTupleConstraint{} - -> ErrorWithoutFlag - TcRnNonTypeVarArgInConstraint{} - -> ErrorWithoutFlag - TcRnIllegalImplicitParam{} - -> ErrorWithoutFlag - TcRnIllegalConstraintSynonymOfKind{} - -> ErrorWithoutFlag - TcRnIllegalClassInst{} - -> ErrorWithoutFlag - TcRnOversaturatedVisibleKindArg{} - -> ErrorWithoutFlag - TcRnBadAssociatedType{} - -> ErrorWithoutFlag - TcRnForAllRankErr{} - -> ErrorWithoutFlag - TcRnMonomorphicBindings{} - -> WarningWithFlag Opt_WarnMonomorphism - TcRnOrphanInstance{} - -> WarningWithFlag Opt_WarnOrphans - TcRnFunDepConflict{} - -> ErrorWithoutFlag - TcRnDupInstanceDecls{} - -> ErrorWithoutFlag - TcRnConflictingFamInstDecls{} - -> ErrorWithoutFlag - TcRnFamInstNotInjective{} - -> ErrorWithoutFlag - TcRnBangOnUnliftedType{} - -> WarningWithFlag Opt_WarnRedundantStrictnessFlags - TcRnMultipleDefaultDeclarations{} - -> ErrorWithoutFlag - TcRnBadDefaultType{} - -> ErrorWithoutFlag - TcRnPatSynBundledWithNonDataCon{} - -> ErrorWithoutFlag - TcRnPatSynBundledWithWrongType{} - -> ErrorWithoutFlag - TcRnDupeModuleExport{} - -> WarningWithFlag Opt_WarnDuplicateExports - TcRnExportedModNotImported{} - -> ErrorWithoutFlag - TcRnNullExportedModule{} - -> WarningWithFlag Opt_WarnDodgyExports - TcRnMissingExportList{} - -> WarningWithFlag Opt_WarnMissingExportList - TcRnExportHiddenComponents{} - -> ErrorWithoutFlag - TcRnDuplicateExport{} - -> WarningWithFlag Opt_WarnDuplicateExports - TcRnExportedParentChildMismatch{} - -> ErrorWithoutFlag - TcRnConflictingExports{} - -> ErrorWithoutFlag - TcRnAmbiguousField{} - -> WarningWithFlag Opt_WarnAmbiguousFields - TcRnMissingFields{} - -> WarningWithFlag Opt_WarnMissingFields - TcRnFieldUpdateInvalidType{} - -> ErrorWithoutFlag - TcRnNoConstructorHasAllFields{} - -> ErrorWithoutFlag - TcRnMixedSelectors{} - -> ErrorWithoutFlag - TcRnMissingStrictFields{} - -> ErrorWithoutFlag - TcRnNoPossibleParentForFields{} - -> ErrorWithoutFlag - TcRnBadOverloadedRecordUpdate{} - -> ErrorWithoutFlag - TcRnStaticFormNotClosed{} - -> ErrorWithoutFlag - TcRnUselessTypeable - -> WarningWithFlag Opt_WarnDerivingTypeable - TcRnDerivingDefaults{} - -> WarningWithFlag Opt_WarnDerivingDefaults - TcRnNonUnaryTypeclassConstraint{} - -> ErrorWithoutFlag - TcRnPartialTypeSignatures{} - -> WarningWithFlag Opt_WarnPartialTypeSignatures - TcRnCannotDeriveInstance _ _ _ _ rea - -> case rea of - DerivErrNotWellKinded{} -> ErrorWithoutFlag - DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag - DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag - DerivErrNoEtaReduce{} -> ErrorWithoutFlag - DerivErrBootFileFound -> ErrorWithoutFlag - DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag - DerivErrGNDUsedOnData -> ErrorWithoutFlag - DerivErrNullaryClasses -> ErrorWithoutFlag - DerivErrLastArgMustBeApp -> ErrorWithoutFlag - DerivErrNoFamilyInstance{} -> ErrorWithoutFlag - DerivErrNotStockDeriveable{} -> ErrorWithoutFlag - DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag - DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag - DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag - DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag - DerivErrNotDeriveable{} -> ErrorWithoutFlag - DerivErrNotAClass{} -> ErrorWithoutFlag - DerivErrNoConstructors{} -> ErrorWithoutFlag - DerivErrLangExtRequired{} -> ErrorWithoutFlag - DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag - DerivErrMustBeEnumType{} -> ErrorWithoutFlag - DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag - DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag - DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag - DerivErrBadConstructor{} -> ErrorWithoutFlag - DerivErrGenerics{} -> ErrorWithoutFlag - DerivErrEnumOrProduct{} -> ErrorWithoutFlag - TcRnLazyGADTPattern - -> ErrorWithoutFlag - TcRnArrowProcGADTPattern - -> ErrorWithoutFlag - TcRnSpecialClassInst {} - -> ErrorWithoutFlag - TcRnForallIdentifier {} - -> WarningWithFlag Opt_WarnForallIdentifier - TcRnTypeEqualityOutOfScope - -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope - TcRnTypeEqualityRequiresOperators - -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators - TcRnIllegalTypeOperator {} - -> ErrorWithoutFlag - TcRnGADTMonoLocalBinds {} - -> WarningWithFlag Opt_WarnGADTMonoLocalBinds - TcRnIncorrectNameSpace {} - -> ErrorWithoutFlag - TcRnNotInScope {} - -> ErrorWithoutFlag - TcRnUntickedPromotedThing {} - -> WarningWithFlag Opt_WarnUntickedPromotedConstructors - TcRnIllegalBuiltinSyntax {} - -> ErrorWithoutFlag - TcRnWarnDefaulting {} - -> WarningWithFlag Opt_WarnTypeDefaults - TcRnForeignImportPrimExtNotSet{} - -> ErrorWithoutFlag - TcRnForeignImportPrimSafeAnn{} - -> ErrorWithoutFlag - TcRnForeignFunctionImportAsValue{} - -> ErrorWithoutFlag - TcRnFunPtrImportWithoutAmpersand{} - -> WarningWithFlag Opt_WarnDodgyForeignImports - TcRnIllegalForeignDeclBackend{} - -> ErrorWithoutFlag - TcRnUnsupportedCallConv _ unsupportedCC - -> case unsupportedCC of - StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions - _ -> ErrorWithoutFlag - TcRnIllegalForeignType{} - -> ErrorWithoutFlag - TcRnInvalidCIdentifier{} - -> ErrorWithoutFlag - TcRnCannotDefaultConcrete{} - -> ErrorWithoutFlag - - diagnosticHints = \case - TcRnUnknownMessage m - -> diagnosticHints m - TcRnMessageWithInfo _ msg_with_info - -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticHints m - TcRnSolverReport _ _ hints - -> hints - TcRnRedundantConstraints{} - -> noHints - TcRnInaccessibleCode{} - -> noHints - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> noHints - TcRnImplicitLift{} - -> noHints - TcRnUnusedPatternBinds{} - -> noHints - TcRnDodgyImports{} - -> noHints - TcRnDodgyExports{} - -> noHints - TcRnMissingImportList{} - -> noHints - TcRnUnsafeDueToPlugin{} - -> noHints - TcRnModMissingRealSrcSpan{} - -> noHints - TcRnIdNotExportedFromModuleSig name mod - -> [SuggestAddToHSigExportList name $ Just mod] - TcRnIdNotExportedFromLocalSig name - -> [SuggestAddToHSigExportList name Nothing] - TcRnShadowedName{} - -> noHints - TcRnDuplicateWarningDecls{} - -> noHints - TcRnSimplifierTooManyIterations{} - -> [SuggestIncreaseSimplifierIterations] - TcRnIllegalPatSynDecl{} - -> noHints - TcRnLinearPatSyn{} - -> noHints - TcRnEmptyRecordUpdate{} - -> noHints - TcRnIllegalFieldPunning{} - -> [suggestExtension LangExt.NamedFieldPuns] - TcRnIllegalWildcardsInRecord{} - -> [suggestExtension LangExt.RecordWildCards] - TcRnIllegalWildcardInType{} - -> noHints - TcRnDuplicateFieldName{} - -> noHints - TcRnIllegalViewPattern{} - -> [suggestExtension LangExt.ViewPatterns] - TcRnCharLiteralOutOfRange{} - -> noHints - TcRnIllegalWildcardsInConstructor{} - -> noHints - TcRnIgnoringAnnotations{} - -> noHints - TcRnAnnotationInSafeHaskell - -> noHints - TcRnInvalidTypeApplication{} - -> noHints - TcRnTagToEnumMissingValArg - -> noHints - TcRnTagToEnumUnspecifiedResTy{} - -> noHints - TcRnTagToEnumResTyNotAnEnum{} - -> noHints - TcRnArrowIfThenElsePredDependsOnResultTy - -> noHints - TcRnIllegalHsBootFileDecl - -> noHints - TcRnRecursivePatternSynonym{} - -> noHints - TcRnPartialTypeSigTyVarMismatch{} - -> noHints - TcRnPartialTypeSigBadQuantifier{} - -> noHints - TcRnMissingSignature {} - -> noHints - TcRnPolymorphicBinderMissingSig{} - -> noHints - TcRnOverloadedSig{} - -> noHints - TcRnTupleConstraintInst{} - -> noHints - TcRnAbstractClassInst{} - -> noHints - TcRnNoClassInstHead{} - -> noHints - TcRnUserTypeError{} - -> noHints - TcRnConstraintInKind{} - -> noHints - TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _ - -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum] - TcRnLinearFuncInKind{} - -> noHints - TcRnForAllEscapeError{} - -> noHints - TcRnVDQInTermType{} - -> noHints - TcRnBadQuantPredHead{} - -> noHints - TcRnIllegalTupleConstraint{} - -> [suggestExtension LangExt.ConstraintKinds] - TcRnNonTypeVarArgInConstraint{} - -> [suggestExtension LangExt.FlexibleContexts] - TcRnIllegalImplicitParam{} - -> noHints - TcRnIllegalConstraintSynonymOfKind{} - -> [suggestExtension LangExt.ConstraintKinds] - TcRnIllegalClassInst{} - -> noHints - TcRnOversaturatedVisibleKindArg{} - -> noHints - TcRnBadAssociatedType{} - -> noHints - TcRnForAllRankErr rank _ - -> case rank of - LimitedRank{} -> [suggestExtension LangExt.RankNTypes] - MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes] - MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes] - MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms] - MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints] - _ -> noHints - TcRnMonomorphicBindings bindings - -> case bindings of - [] -> noHints - (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] - TcRnOrphanInstance{} - -> [SuggestFixOrphanInstance] - TcRnFunDepConflict{} - -> noHints - TcRnDupInstanceDecls{} - -> noHints - TcRnConflictingFamInstDecls{} - -> noHints - TcRnFamInstNotInjective rea _ _ - -> case rea of - InjErrRhsBareTyVar{} -> noHints - InjErrRhsCannotBeATypeFam -> noHints - InjErrRhsOverlap -> noHints - InjErrCannotInferFromRhs _ _ suggestUndInst - | YesSuggestUndecidableInstaces <- suggestUndInst - -> [suggestExtension LangExt.UndecidableInstances] - | otherwise - -> noHints - TcRnBangOnUnliftedType{} - -> noHints - TcRnMultipleDefaultDeclarations{} - -> noHints - TcRnBadDefaultType{} - -> noHints - TcRnPatSynBundledWithNonDataCon{} - -> noHints - TcRnPatSynBundledWithWrongType{} - -> noHints - TcRnDupeModuleExport{} - -> noHints - TcRnExportedModNotImported{} - -> noHints - TcRnNullExportedModule{} - -> noHints - TcRnMissingExportList{} - -> noHints - TcRnExportHiddenComponents{} - -> noHints - TcRnDuplicateExport{} - -> noHints - TcRnExportedParentChildMismatch{} - -> noHints - TcRnConflictingExports{} - -> noHints - TcRnAmbiguousField{} - -> noHints - TcRnMissingFields{} - -> noHints - TcRnFieldUpdateInvalidType{} - -> noHints - TcRnNoConstructorHasAllFields{} - -> noHints - TcRnMixedSelectors{} - -> noHints - TcRnMissingStrictFields{} - -> noHints - TcRnNoPossibleParentForFields{} - -> noHints - TcRnBadOverloadedRecordUpdate{} - -> noHints - TcRnStaticFormNotClosed{} - -> noHints - TcRnUselessTypeable - -> noHints - TcRnDerivingDefaults{} - -> [useDerivingStrategies] - TcRnNonUnaryTypeclassConstraint{} - -> noHints - TcRnPartialTypeSignatures suggestParSig _ - -> case suggestParSig of - YesSuggestPartialTypeSignatures - -> let info = text "to use the inferred type" - in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] - NoSuggestPartialTypeSignatures - -> noHints - TcRnCannotDeriveInstance cls _ _ newtype_deriving rea - -> deriveInstanceErrReasonHints cls newtype_deriving rea - TcRnLazyGADTPattern - -> noHints - TcRnArrowProcGADTPattern - -> noHints - TcRnSpecialClassInst {} - -> noHints - TcRnForallIdentifier {} - -> [SuggestRenameForall] - TcRnTypeEqualityOutOfScope - -> noHints - TcRnTypeEqualityRequiresOperators - -> [suggestExtension LangExt.TypeOperators] - TcRnIllegalTypeOperator {} - -> [suggestExtension LangExt.TypeOperators] - TcRnGADTMonoLocalBinds {} - -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] - TcRnIncorrectNameSpace nm is_th_use - | is_th_use - -> [SuggestAppropriateTHTick $ nameNameSpace nm] - | otherwise - -> noHints - TcRnNotInScope err _ _ hints - -> scopeErrorHints err ++ hints - TcRnUntickedPromotedThing thing - -> [SuggestAddTick thing] - TcRnIllegalBuiltinSyntax {} - -> noHints - TcRnWarnDefaulting {} - -> noHints - TcRnForeignImportPrimExtNotSet{} - -> [suggestExtension LangExt.GHCForeignImportPrim] - TcRnForeignImportPrimSafeAnn{} - -> noHints - TcRnForeignFunctionImportAsValue{} - -> noHints - TcRnFunPtrImportWithoutAmpersand{} - -> noHints - TcRnIllegalForeignDeclBackend{} - -> noHints - TcRnUnsupportedCallConv{} - -> noHints - TcRnIllegalForeignType _ reason - -> case reason of - TypeCannotBeMarshaled _ why - | NewtypeDataConNotInScope{} <- why -> [SuggestImportingDataCon] - | UnliftedFFITypesNeeded <- why -> [suggestExtension LangExt.UnliftedFFITypes] - _ -> noHints - TcRnInvalidCIdentifier{} - -> noHints - TcRnCannotDefaultConcrete{} - -> [SuggestAddTypeSignatures UnnamedBinding] - - -deriveInstanceErrReasonHints :: Class - -> UsingGeneralizedNewtypeDeriving - -> DeriveInstanceErrReason - -> [GhcHint] -deriveInstanceErrReasonHints cls newtype_deriving = \case - DerivErrNotWellKinded _ _ n_args_to_keep - | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 - -> [suggestExtension LangExt.PolyKinds] - | otherwise - -> noHints - DerivErrSafeHaskellGenericInst -> noHints - DerivErrDerivingViaWrongKind{} -> noHints - DerivErrNoEtaReduce{} -> noHints - DerivErrBootFileFound -> noHints - DerivErrDataConsNotAllInScope{} -> noHints - DerivErrGNDUsedOnData -> noHints - DerivErrNullaryClasses -> noHints - DerivErrLastArgMustBeApp -> noHints - DerivErrNoFamilyInstance{} -> noHints - DerivErrNotStockDeriveable deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrHasAssociatedDatatypes{} - -> noHints - DerivErrNewtypeNonDeriveableClass - | newtype_deriving == NoGeneralizedNewtypeDeriving - -> [useGND] - | otherwise - -> noHints - DerivErrCannotEtaReduceEnough{} - | newtype_deriving == NoGeneralizedNewtypeDeriving - -> [useGND] - | otherwise - -> noHints - DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrNotDeriveable deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrNotAClass{} - -> noHints - DerivErrNoConstructors{} - -> let info = text "to enable deriving for empty data types" - in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] - DerivErrLangExtRequired{} - -- This is a slightly weird corner case of GHC: we are failing - -- to derive a typeclass instance because a particular 'Extension' - -- is not enabled (and so we report in the main error), but here - -- we don't want to /repeat/ to enable the extension in the hint. - -> noHints - DerivErrDunnoHowToDeriveForType{} - -> noHints - DerivErrMustBeEnumType rep_tc - -- We want to suggest GND only if this /is/ a newtype. - | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc - -> [useGND] - | otherwise - -> noHints - DerivErrMustHaveExactlyOneConstructor{} - -> noHints - DerivErrMustHaveSomeParameters{} - -> noHints - DerivErrMustNotHaveClassContext{} - -> noHints - DerivErrBadConstructor wcard _ - -> case wcard of - Nothing -> noHints - Just YesHasWildcard -> [SuggestFillInWildcardConstraint] - Just NoHasWildcard -> [SuggestAddStandaloneDerivation] - DerivErrGenerics{} - -> noHints - DerivErrEnumOrProduct{} - -> noHints - -messageWithInfoDiagnosticMessage :: UnitState - -> ErrInfo - -> DecoratedSDoc - -> DecoratedSDoc -messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important = - let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary] - in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` - mkDecorated err_info' - -dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc -dodgy_msg kind tc ie - = sep [ text "The" <+> kind <+> text "item" - <+> quotes (ppr ie) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - -dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) -dodgy_msg_insert tc = IEThingAll noAnn ii - where - ii :: LIEWrappedName (IdP (GhcPass p)) - ii = noLocA (IEName $ noLocA tc) - -pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc -pprTypeDoesNotHaveFixedRuntimeRep ty prov = - let what = pprFixedRuntimeRepProvenance prov - in text "The" <+> what <+> text "does not have a fixed runtime representation:" - $$ format_frr_err ty - -format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation - -> SDoc -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) - -pprField :: (FieldLabelString, TcType) -> SDoc -pprField (f,ty) = ppr f <+> dcolon <+> ppr ty - -pprRecordFieldPart :: RecordFieldPart -> SDoc -pprRecordFieldPart = \case - RecordFieldConstructor{} -> text "construction" - RecordFieldPattern{} -> text "pattern" - RecordFieldUpdate -> text "update" - -pprBindings :: [Name] -> SDoc -pprBindings = pprWithCommas (quotes . ppr) - -injectivityErrorHerald :: SDoc -injectivityErrorHerald = - text "Type family equation violates the family's injectivity annotation." - -formatExportItemError :: SDoc -> String -> SDoc -formatExportItemError exportedThing reason = - hsep [ text "The export item" - , quotes exportedThing - , text reason ] - --- | What warning flag is associated with the given missing signature? -missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag -missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden - | IsExported <- exported - , not overridden - = Opt_WarnMissingExportedSignatures - | otherwise - = Opt_WarnMissingSignatures -missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden - | IsExported <- exported - , not overridden - = Opt_WarnMissingExportedPatternSynonymSignatures - | otherwise - = Opt_WarnMissingPatternSynonymSignatures -missingSignatureWarningFlag (MissingTyConKindSig {}) _ _ - = Opt_WarnMissingKindSignatures - -useDerivingStrategies :: GhcHint -useDerivingStrategies = - useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies - -useGND :: GhcHint -useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" - in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving - -cannotMakeDerivedInstanceHerald :: Class - -> [Type] - -> Maybe (DerivStrategy GhcTc) - -> UsingGeneralizedNewtypeDeriving - -> Bool -- ^ If False, only prints the why. - -> SDoc - -> SDoc -cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = - if pprHerald - then sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - else why - where - strat_used = isJust mb_strat - extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - , Just strat <- mb_strat - = text "with the" <+> (derivStrategyName strat) <+> text "strategy" - | otherwise - = empty - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - -derivErrDiagnosticMessage :: Class - -> [Type] - -> Maybe (DerivStrategy GhcTc) - -> UsingGeneralizedNewtypeDeriving - -> Bool -- If True, includes the herald \"can't make a derived..\" - -> DeriveInstanceErrReason - -> SDoc -derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case - DerivErrNotWellKinded tc cls_kind _ - -> sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 empty - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - DerivErrSafeHaskellGenericInst - -> text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - DerivErrDerivingViaWrongKind cls_kind via_ty via_kind - -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - DerivErrNoEtaReduce inst_ty - -> sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - DerivErrBootFileFound - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") - DerivErrDataConsNotAllInScope tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") - 2 (text "so you cannot derive an instance for it")) - DerivErrGNDUsedOnData - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") - DerivErrNullaryClasses - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Cannot derive instances for nullary classes") - DerivErrLastArgMustBeApp - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - ( text "The last argument of the instance must be a" - <+> text "data or newtype application") - DerivErrNoFamilyInstance tc tc_args - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) - DerivErrNotStockDeriveable _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") - DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg - , case at_without_last_cls_tv of - YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc - NoAssociatedTyNotParamOverLastTyVar -> empty - , case at_last_cls_tv_in_kinds of - YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc - NoAssocTyLastVarInKind -> empty - ] - where - - adfs_msg = text "the class has associated data types" - - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - DerivErrNewtypeNonDeriveableClass - -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) - DerivErrCannotEtaReduceEnough eta_ok - -> let cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - cant_derive_err - DerivErrOnlyAnyClassDeriveable tc _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled") - DerivErrNotDeriveable _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty - DerivErrNotAClass predType - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr predType) <+> text "is not a class") - DerivErrNoConstructors rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") - DerivErrLangExtRequired ext - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "You need " <> ppr ext - <+> text "to derive an instance for this class") - DerivErrDunnoHowToDeriveForType ty - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - DerivErrMustBeEnumType rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) - - DerivErrMustHaveExactlyOneConstructor rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") - DerivErrMustHaveSomeParameters rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") - DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - DerivErrBadConstructor _ reasons - -> let why = vcat $ map renderReason reasons - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why - where - renderReason = \case - DerivErrBadConExistential con - -> badCon con $ text "must be truly polymorphic in the last argument of the data type" - DerivErrBadConCovariant con - -> badCon con $ text "must not use the type variable in a function argument" - DerivErrBadConFunTypes con - -> badCon con $ text "must not contain function types" - DerivErrBadConWrongArg con - -> badCon con $ text "must use the type variable only as the last argument of a data type" - DerivErrBadConIsGADT con - -> badCon con $ text "is a GADT" - DerivErrBadConHasExistentials con - -> badCon con $ text "has existential type variables in its type" - DerivErrBadConHasConstraints con - -> badCon con $ text "has constraints in its type" - DerivErrBadConHasHigherRankType con - -> badCon con $ text "has a higher-rank type" - DerivErrGenerics reasons - -> let why = vcat $ map renderReason reasons - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why - where - renderReason = \case - DerivErrGenericsMustNotHaveDatatypeContext tc_name - -> ppr tc_name <+> text "must not have a datatype context" - DerivErrGenericsMustNotHaveExoticArgs dc - -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" - DerivErrGenericsMustBeVanillaDataCon dc - -> ppr dc <+> text "must be a vanilla data constructor" - DerivErrGenericsMustHaveSomeTypeParams rep_tc - -> text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - DerivErrGenericsMustNotHaveExistentials con - -> badCon con $ text "must not have existential arguments" - DerivErrGenericsWrongArgKind con - -> badCon con $ - text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - DerivErrEnumOrProduct this that - -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this - ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (ppr1 $$ text " or" $$ ppr2) - -{- ********************************************************************* -* * - Outputable SolverReportErrCtxt (for debugging) -* * -**********************************************************************-} - -instance Outputable SolverReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_expand_syns = es - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_expand_syns" <+> equals <+> ppr es - , text "cec_suppress" <+> equals <+> ppr sup ]) - -{- ********************************************************************* -* * - Outputting TcSolverReportMsg errors -* * -**********************************************************************-} - --- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' --- with its enclosing 'SolverReportErrCtxt'. -pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc -pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) - = pprTcSolverReportMsg ctxt msg - --- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. -pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc -pprTcSolverReportMsg ctxt (TcReportWithInfo msg (info :| infos)) = - vcat - ( pprTcSolverReportMsg ctxt msg - : pprTcSolverReportInfo ctxt info - : map (pprTcSolverReportInfo ctxt) infos ) -pprTcSolverReportMsg _ (BadTelescope telescope skols) = - hang (text "These kind and type variables:" <+> ppr telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - where - sorted_tvs = scopedSort skols -pprTcSolverReportMsg _ (UserTypeError ty) = - pprUserTypeErrorTy ty -pprTcSolverReportMsg ctxt (ReportHoleError hole err) = - pprHoleError ctxt hole err -pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) = - vcat [ (if isSkolemTyVar tv1 - then text "Cannot equate type variable" - else text "Cannot instantiate unification variable") - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel -pprTcSolverReportMsg _ - (Mismatch { mismatch_ea = add_ea - , mismatch_item = item - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 }) - = addArising (errorItemOrigin item) msg - where - msg - | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || - (isLiftedLevity ty1 && isUnliftedLevity ty2) || - (isLiftedLevity ty2 && isUnliftedLevity ty1) - = text "Couldn't match a lifted type with an unlifted type" - - | isAtomicTy ty1 || isAtomicTy ty2 - = -- Print with quotes - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) ] - - | otherwise - = -- Print with vertical layout - vcat [ text herald1 <> colon <+> ppr ty1 - , nest padding $ - text herald2 <> colon <+> ppr ty2 ] - - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if add_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if add_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) -pprTcSolverReportMsg _ - (KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act }) - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | tcIsConstraintKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - - -pprTcSolverReportMsg 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_what = mb_thing }) - = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - 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 - 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 $$ pprTcSolverReportMsg 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 - = pprTcSolverReportMsg ctxt ea_msg - -- The mismatched types are /inside/ exp and act - | let mismatch_err = Mismatch False item ty1 ty2 - errs = case mk_ea_msg ctxt Nothing level orig of - Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] - Right ea_err -> [ mismatch_err, ea_err ] - = vcat $ map (pprTcSolverReportMsg ctxt) errs - - 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) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- mb_thing - -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty -pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = - vcat (map make_msg frr_origs) - where - -- Assemble the error message: pair up each origin with the corresponding type, e.g. - -- • FixedRuntimeRep origin msg 1 ... - -- a :: TYPE r1 - -- • FixedRuntimeRep origin msg 2 ... - -- b :: TYPE r2 - make_msg :: FixedRuntimeRepErrorInfo -> SDoc - make_msg (FRR_Info { frr_info_origin = - FixedRuntimeRepOrigin - { frr_type = ty - , frr_context = frr_ctxt } - , frr_info_not_concrete = - mb_not_conc }) = - -- Add bullet points if there is more than one error. - (if length frr_origs > 1 then (bullet <+>) else id) $ - vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt - , text "does not have a fixed runtime representation." ] - , type_printout ty - , case mb_not_conc of - Nothing -> empty - Just (conc_tv, not_conc) -> - unsolved_concrete_eq_explanation conc_tv not_conc ] - - -- Don't print out the type (only the kind), if the type includes - -- a confusing cast, unless the user passed -fprint-explicit-coercions. - -- - -- Example: - -- - -- In T20363, we have a representation-polymorphism error with a type - -- of the form - -- - -- ( (# #) |> co ) :: TYPE NilRep - -- - -- where NilRep is a nullary type family application which reduces to TupleRep '[]. - -- We prefer avoiding showing the cast to the user, but we also don't want to - -- print the confusing: - -- - -- (# #) :: TYPE NilRep - -- - -- So in this case we simply don't print the type, only the kind. - confusing_cast :: Type -> Bool - confusing_cast ty = - case ty of - CastTy inner_ty _ - -- A confusing cast is one that is responsible - -- for a representation-polymorphism error. - -> isConcrete (typeKind inner_ty) - _ -> False - - type_printout :: Type -> SDoc - type_printout ty = - sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> - if confusing_cast ty && not show_coercions - then vcat [ text "Its kind is:" - , nest 2 $ pprWithTYPE (typeKind ty) - , text "(Use -fprint-explicit-coercions to see the full type.)" ] - else vcat [ text "Its type is:" - , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] - - unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc - unsolved_concrete_eq_explanation tv not_conc = - text "Cannot unify" <+> quotes (ppr not_conc) - <+> text "with the type variable" <+> quotes (ppr tv) - $$ text "because it is not a concrete" <+> what <> dot - where - ki = tyVarKind tv - what :: SDoc - what - | isRuntimeRepTy ki - = quotes (text "RuntimeRep") - | isLevityTy ki - = quotes (text "Levity") - | otherwise - = text "type" - -pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) = - let - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - in - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr (ic_info implic) - , nest 2 $ text "at" <+> - ppr (getLclEnvLoc (ic_env implic)) ] ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel -pprTcSolverReportMsg _ (UntouchableVariable tv implic) - | Implic { ic_given = given, ic_info = skol_info } <- implic - = sep [ quotes (ppr tv) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (getLclEnvLoc (ic_env implic)) ] -pprTcSolverReportMsg _ (BlockedEquality item) = - vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (errorItemPred item)) - , text "Doing so would be ill-kinded." ] -pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = - text "Expecting" <+> speakN (abs n) <+> - more <+> quotes (ppr thing) - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 -pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = - let givens = getUserGivens ctxt - in if null givens - then addArising (errorItemOrigin item) $ - sep [ text "Unbound implicit parameter" <> plural preds - , nest 2 (pprParendTheta preds) ] - else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) - where - preds = map errorItemPred (item : items) -pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) - = main_msg $$ - case supplementary of - Left infos - -> vcat (map (pprTcSolverReportInfo ctxt) infos) - Right other_msg - -> pprTcSolverReportMsg ctxt other_msg - where - main_msg - | null useful_givens - = addArising orig (no_instance_msg <+> missing) - | otherwise - = vcat (addArising orig (no_deduce_msg <+> missing) - : pp_givens useful_givens) - - supplementary = case mb_extra of - Nothing - -> Left [] - Just (CND_Extra level ty1 ty2) - -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig - orig = errorItemOrigin item - wanteds = map errorItemPred (item:others) - - no_instance_msg = - case wanteds of - [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted - -- Don't say "no instance" for a constraint such as "c" for a type variable c. - , isClassTyCon tc -> text "No instance for" - _ -> text "Could not solve:" - - no_deduce_msg = - case wanteds of - [_wanted] -> text "Could not deduce" - _ -> text "Could not deduce:" - - missing = - case wanteds of - [wanted] -> pprParendType wanted - _ -> pprTheta wanteds - -pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) = - pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> - pprArising (errorItemOrigin item) $$ - text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) - <+> text "from being solved." -pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) - (CannotResolveInstance item unifiers candidates imp_errs suggs binds) - = - vcat - [ pprTcSolverReportMsg ctxt no_inst_msg - , nest 2 extra_note - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig $ - pprTcSolverReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs)) - , pprRelevantBindings binds - , potential_msg ]) - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambigs pred implics - ++ drv_fixes) - , ppWhen (not (null candidates)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidates))) - -- See Note [Report candidate instances] - , vcat $ map ppr imp_errs - , vcat $ map ppr suggs ] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - -- See Note [Highlighting ambiguous type variables] - (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred - ambigs = ambig_kvs ++ ambig_tvs - has_ambigs = not (null ambigs) - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - lead_with_ambig = not (null ambigs) - && not (any isRuntimeUnkSkol ambigs) - && not (null unifiers) - && null useful_givens - - no_inst_msg :: TcSolverReportMsg - no_inst_msg - | lead_with_ambig - = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) - | otherwise - = CouldNotDeduce useful_givens (item :| []) Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - potential_hdr $$ - potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) - - potential_hdr - = ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - -pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = - vcat - [ addArising orig $ - (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - , potentialInstancesErrMsg - (PotentialInstances { matches, unifiers }) - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ ppUnless (null tyCoVars) $ - text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr tyCoVars) - , ppUnless (null famTyCons) $ - if (null tyCoVars) - then - text "The choice depends on the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - else - text "and the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - tyCoVars = tyCoVarsOfTypesList tys - famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - matching_givens = mapMaybe matchable useful_givens - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (getLclEnvLoc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False -pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) = - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head matches)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_overlapped]) - ] - ] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - -{- ********************************************************************* -* * - Displaying potential instances -* * -**********************************************************************-} - --- | Directly display the given matching and unifying instances, --- with a header for each: `Matching instances`/`Potentially matching instances`. -pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc -pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = - vcat - [ ppWhen (not $ null matches) $ - text "Matching instance" <> plural matches <> colon $$ - nest 2 (vcat (map ppr_inst matches)) - , ppWhen (not $ null unifiers) $ - (text "Potentially matching instance" <> plural unifiers <> colon) $$ - nest 2 (vcat (map ppr_inst unifiers)) - ] - --- | Display a summary of available instances, omitting those involving --- out-of-scope types, in order to explain why we couldn't solve a particular --- constraint, e.g. due to instance overlap or out-of-scope types. --- --- To directly display a collection of matching/unifying instances, --- use 'pprPotentialInstances'. -potentialInstancesErrMsg :: PotentialInstances -> SDoc --- See Note [Displaying potential instances] -potentialInstancesErrMsg potentials = - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - potentials_msg_with_options potentials print_insts sty - --- | Display a summary of available instances, omitting out-of-scope ones. --- --- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing --- options. -potentials_msg_with_options :: PotentialInstances - -> Bool -- ^ Whether to print /all/ potential instances - -> PprStyle - -> SDoc -potentials_msg_with_options - (PotentialInstances { matches, unifiers }) - show_all_potentials sty - | null matches && null unifiers - = empty - - | null show_these_matches && null show_these_unifiers - = vcat [ not_in_scope_msg empty - , flag_hint ] - - | otherwise - = vcat [ pprPotentialInstances - pprInstance -- print instance + location info - (PotentialInstances - { matches = show_these_matches - , unifiers = show_these_unifiers }) - , overlapping_but_not_more_specific_msg sorted_matches - , nest 2 $ vcat - [ ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , ppWhen (not_in_scopes > 0) $ - not_in_scope_msg (text "...plus") - , flag_hint ] ] - where - n_show_matches, n_show_unifiers :: Int - n_show_matches = 3 - n_show_unifiers = 2 - - (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches - (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers - sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches - sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers - (show_these_matches, show_these_unifiers) - | show_all_potentials = (sorted_matches, sorted_unifiers) - | otherwise = (take n_show_matches sorted_matches - ,take n_show_unifiers sorted_unifiers) - n_in_scope_hidden - = length sorted_matches + length sorted_unifiers - - length show_these_matches - length show_these_unifiers - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | pretendNameIsInScope name - = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scopes :: Int - not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers - - not_in_scope_msg herald = - hang (herald <+> speakNOf not_in_scopes (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_all_potentials $ - pprPotentialInstances - pprInstanceHdr -- only print the header, not the instance location info - (PotentialInstances - { matches = not_in_scope_matches - , unifiers = not_in_scope_unifiers - })) - - flag_hint = ppUnless (show_all_potentials - || (equalLength show_these_matches matches - && equalLength show_these_unifiers unifiers)) $ - text "(use -fprint-potential-instances to see them all)" - --- | Compute a message informing the user of any instances that are overlapped --- but were not discarded because the instance overlapping them wasn't --- strictly more specific. -overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc -overlapping_but_not_more_specific_msg insts - -- Only print one example of "overlapping but not strictly more specific", - -- to avoid information overload. - | overlap : _ <- overlapping_but_not_more_specific - = overlap_header $$ ppr_overlapping overlap - | otherwise - = empty - where - overlap_header :: SDoc - overlap_header - | [_] <- overlapping_but_not_more_specific - = text "An overlapping instance can only be chosen when it is strictly more specific." - | otherwise - = text "Overlapping instances can only be chosen when they are strictly more specific." - overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] - overlapping_but_not_more_specific - = nubOrdBy (comparing (is_dfun . fst)) - [ (overlapper, overlappee) - | these <- groupBy ((==) `on` is_cls_nm) insts - -- Take all pairs of distinct instances... - , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` - , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` - -- ... such that one instance in the pair overlaps the other... - , let mb_overlapping - | hasOverlappingFlag (overlapMode $ is_flag one) - || hasOverlappableFlag (overlapMode $ is_flag other) - = [(one, other)] - | hasOverlappingFlag (overlapMode $ is_flag other) - || hasOverlappableFlag (overlapMode $ is_flag one) - = [(other, one)] - | otherwise - = [] - , (overlapper, overlappee) <- mb_overlapping - -- ... but the overlapper is not more specific than the overlappee. - , not (overlapper `more_specific_than` overlappee) - ] - more_specific_than :: ClsInst -> ClsInst -> Bool - is1 `more_specific_than` is2 - = isJust (tcMatchTys (is_tys is1) (is_tys is2)) - ppr_overlapping :: (ClsInst, ClsInst) -> SDoc - ppr_overlapping (overlapper, overlappee) - = text "The first instance that follows overlaps the second, but is not more specific than it:" - $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus N others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- ********************************************************************* -* * - Outputting TcSolverReportInfo -* * -**********************************************************************-} - --- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. -pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc -pprTcSolverReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg - where - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" -pprTcSolverReportInfo ctxt (TyVarInfo tv ) = - case tcTyVarDetails tv of - SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty -pprTcSolverReportInfo _ (NonInjectiveTyFam tc) = - text "NB:" <+> quotes (ppr tc) - <+> text "is a non-injective type family" -pprTcSolverReportInfo _ (ReportCoercibleMsg msg) = - pprCoercibleMsg msg -pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = - vcat - [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] -pprTcSolverReportInfo _ - (ExpectedActualAfterTySynExpansion - { ea_expanded_expected = exp - , ea_expanded_actual = act } ) - = vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr exp - , text " Actual type:" <+> ppr act ] -pprTcSolverReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = - sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - if printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - then vcat [ hang (text "When matching" <+> sub_whats) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - , supplementary ] - else text "When matching the kind of" <+> quotes (ppr cty1) - where - sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel - sub_whats = text (levelString sub_t_or_k) <> char 's' - supplementary = - case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of - Left infos -> vcat $ map (pprTcSolverReportInfo ctxt) infos - Right msg -> pprTcSolverReportMsg ctxt msg -pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) = - text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnit) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnit mod - mod = nameModule nm - loc = nameSrcSpan nm -pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - (tv:tvs)) - where - tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - -pprCoercibleMsg :: CoercibleMsg -> SDoc -pprCoercibleMsg (UnknownRoles ty) = - hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr ty) <+> text "have;") - 2 (text "we must assume that the role is nominal") -pprCoercibleMsg (TyConIsAbstract tc) = - hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] -pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = - hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - -{- ********************************************************************* -* * - Outputting HoleError messages -* * -**********************************************************************-} - -pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc -pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs) - = out_of_scope_msg $$ vcat (map ppr imp_errs) - where - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) - boring_type = isTyVarTy hole_ty -pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = - vcat [ hole_msg - , tyvars_msg - , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] - - where - - hole_msg = case sort of - ExprHole {} -> - hang (text "Found hole:") - 2 (pp_occ_with_type hole_occ hole_ty) - TypeHole -> - hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - ConstraintHole -> - hang (text "Found extra-constraints wildcard standing for") - 2 (quotes $ pprType hole_ty) -- always kind constraint - - hole_kind = tcTypeKind hole_ty - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars = tyCoVarsOfTypeList hole_ty - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt hole_skol_info) - -- Coercion variables can be free in the - -- hole, via kind casts - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS hole_occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr hole_occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - type_hole_hint - | ErrorWithoutFlag <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - -pp_occ_with_type :: OccName -> Type -> SDoc -pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - -{- ********************************************************************* -* * - Outputting ScopeError messages -* * -**********************************************************************-} - -pprScopeError :: RdrName -> NotInScopeError -> SDoc -pprScopeError rdr_name scope_err = - case scope_err of - NotInScope {} -> - hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - NoExactName name -> - text "The Name" <+> quotes (ppr name) <+> text "is not in scope." - SameName gres -> - assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) - $ hang (text "Same Name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names)) - where - sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - MissingBinding thing _ -> - sep [ text "The" <+> thing - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding" ] - NoTopLevelBinding -> - hang (text "No top-level binding for") - 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") - UnknownSubordinate doc -> - quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - -scopeErrorHints :: NotInScopeError -> [GhcHint] -scopeErrorHints scope_err = - case scope_err of - NotInScope -> noHints - NoExactName {} -> [SuggestDumpSlices] - SameName {} -> [SuggestDumpSlices] - MissingBinding _ hints -> hints - NoTopLevelBinding -> noHints - UnknownSubordinate {} -> noHints - -{- ********************************************************************* -* * - Outputting ImportError messages -* * -**********************************************************************-} - -instance Outputable ImportError where - ppr (MissingModule mod_name) = - hsep - [ text "NB: no module named" - , quotes (ppr mod_name) - , text "is imported." - ] - ppr (ModulesDoNotExport mods occ_name) - | mod NE.:| [] <- mods - = hsep - [ text "NB: the module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot ] - | otherwise - = hsep - [ text "NB: neither" - , quotedListWithNor (map ppr $ NE.toList mods) - , text "export" - , quotes (ppr occ_name) <> dot ] - -{- ********************************************************************* -* * - Suggested fixes for implication constraints -* * -**********************************************************************-} - --- TODO: these functions should use GhcHint instead. - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -pp_givens :: [Implication] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ]) - -{- ********************************************************************* -* * - CtOrigin information -* * -**********************************************************************-} - -levelString :: TypeOrKind -> String -levelString TypeLevel = "type" -levelString KindLevel = "kind" - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (AmbiguityCheckOrigin {}) = empty -- the "In the ambiguity check" context - -- is sufficient; this would just be - -- repetitive -pprArising orig | isGivenOrigin orig = empty - | otherwise = pprCtOrigin orig - --- Add the "arising from..." part to a message -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> SDoc --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = addArising (ctLocOrigin loc) (pprTheta [ctPred ct]) - | otherwise - = vcat (map ppr_one (ct:cts)) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -{- ********************************************************************* -* * - SkolemInfo -* * -**********************************************************************-} - - -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) - ----------------- -tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon -tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfoAnon _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - 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 = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - -pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc -pprSkols ctxt zonked_ty_vars - = - let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars - in vcat (map pp_one tidy_ty_vars) - where - - no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - - pp_one (UnkSkol cs, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "(rigid, skolem)") - , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) - , no_msg - , prettyCallStackDoc cs - ] - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -skolsSpan :: [TcTyVar] -> SrcSpan -skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) - -{- ********************************************************************* -* * - Utilities for expected/actual messages -* * -**********************************************************************-} - -mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg -mk_supplementary_ea_msg ctxt level ty1 ty2 orig - | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig - , not (ea_looks_same ty1 ty2 exp act) - = mk_ea_msg ctxt Nothing level orig - | otherwise - = Left [] - -ea_looks_same :: Type -> Type -> Type -> Type -> Bool --- True if the faulting types (ty1, ty2) look the same as --- the expected/actual types (exp, act). --- If so, we don't want to redundantly report the latter -ea_looks_same ty1 ty2 exp act - = (act `looks_same` ty1 && exp `looks_same` ty2) || - (exp `looks_same` ty1 && act `looks_same` ty2) - where - looks_same t1 t2 = t1 `pickyEqType` t2 - || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind - -- pickyEqType is sensitive to synonyms, so only replies True - -- when the types really look the same. However, - -- (TYPE 'LiftedRep) and Type both print the same way. - -mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind - -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg --- Constructs a "Couldn't match" message --- The (Maybe ErrorItem) says whether this is the main top-level message (Just) --- or a supplementary message (Nothing) -mk_ea_msg ctxt at_top level - (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) - | Just thing <- mb_thing - , KindLevel <- level - = Right $ KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act } - | Just item <- at_top - , let mismatch = - Mismatch - { mismatch_ea = True - , mismatch_item = item - , mismatch_ty1 = exp - , mismatch_ty2 = act } - = Right $ - if expanded_syns - then mkTcReportWithInfo mismatch [ea_expanded] - else mismatch - | otherwise - = Left $ - if expanded_syns - then [ea,ea_expanded] - else [ea] - - where - ea = ExpectedActual { ea_expected = exp, ea_actual = act } - ea_expanded = - ExpectedActualAfterTySynExpansion - { ea_expanded_expected = expTy1 - , ea_expanded_actual = expTy2 } - - expanded_syns = cec_expand_syns ctxt - && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) - (expTy1, expTy2) = expandSynonymsToMatch exp act -mk_ea_msg _ _ _ _ = Left [] - -{- Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - , tys1 `equalLength` tys2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. The lengths of tys1 and tys2 must be equal; - -- for example, with type S a = a, we don't want - -- to zip (S Monad Int) and (S Bool). - let (tys1', tys2') = - unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Tc.Errors.Ppr + ( pprTypeDoesNotHaveFixedRuntimeRep + , pprScopeError + -- + , tidySkolemInfo + , tidySkolemInfoAnon + -- + , pprHsDocContext + , inHsDocContext + , TcRnMessageOpts(..) + ) + where + +import GHC.Prelude + +import GHC.Builtin.Names +import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon ) + +import GHC.Core.Coercion +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch) +import GHC.Core.ConLike +import GHC.Core.FamInstEnv ( famInstAxiom ) +import GHC.Core.InstEnv +import GHC.Core.TyCo.Rep (Type(..)) +import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, + pprSourceTyCon, pprTyVars, pprWithTYPE) +import GHC.Core.PatSyn ( patSynName, pprPatSynType ) +import GHC.Core.Predicate +import GHC.Core.Type + +import GHC.Driver.Flags +import GHC.Driver.Backend +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint +import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode ) +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Rank (Rank(..)) +import GHC.Tc.Utils.TcType + +import GHC.Types.Error +import GHC.Types.FieldLabel (flIsOverloaded) +import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) +import GHC.Types.Hint.Ppr () -- Outputable GhcHint +import GHC.Types.Basic +import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance + , RdrName, rdrNameOcc, greMangledName ) +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Unit.State (pprWithUnitState, UnitState) +import GHC.Unit.Module +import GHC.Unit.Module.Warnings ( pprWarningTxtForMsg ) + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.List.SetOps ( nubOrdBy ) +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.BooleanFormula (pprBooleanFormulaNice) + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Function (on) +import Data.List ( groupBy, sortBy, tails + , partition, unfoldr ) +import Data.Ord ( comparing ) +import Data.Bifunctor +import GHC.Types.Name.Env +import qualified Language.Haskell.TH as TH + +data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not + } + +defaultTcRnMessageOpts :: TcRnMessageOpts +defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True } + + +instance Diagnostic TcRnMessage where + type DiagnosticOpts TcRnMessage = TcRnMessageOpts + defaultDiagnosticOpts = defaultTcRnMessageOpts + diagnosticMessage opts = \case + TcRnUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m + TcRnMessageWithInfo unit_state msg_with_info + -> case msg_with_info of + TcRnMessageDetailed err_info msg + -> messageWithInfoDiagnosticMessage unit_state err_info + (tcOptsShowContext opts) + (diagnosticMessage opts msg) + TcRnWithHsDocContext ctxt msg + -> if tcOptsShowContext opts + then main_msg `unionDecoratedSDoc` ctxt_msg + else main_msg + where + main_msg = diagnosticMessage opts msg + ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) + TcRnSolverReport msg _ _ + -> mkSimpleDecorated $ pprSolverReportWithCtxt msg + TcRnRedundantConstraints redundants (info, show_info) + -> mkSimpleDecorated $ + text "Redundant constraint" <> plural redundants <> colon + <+> pprEvVarTheta redundants + $$ if show_info then text "In" <+> ppr info else empty + TcRnInaccessibleCode implic contra + -> mkSimpleDecorated $ + hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + $$ pprSolverReportWithCtxt contra + TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) + -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] + TcRnImplicitLift id_or_name ErrInfo{..} + -> mkDecorated $ + ( text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + ) : [errInfoContext, errInfoSupplementary] + TcRnUnusedPatternBinds bind + -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] + TcRnDodgyImports name + -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)] + TcRnDodgyExports name + -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)] + TcRnMissingImportList ie + -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> + text "does not have an explicit import list" + ] + TcRnUnsafeDueToPlugin + -> mkDecorated [text "Use of plugins makes the module unsafe"] + TcRnModMissingRealSrcSpan mod + -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod] + TcRnIdNotExportedFromModuleSig name mod + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the signature for" <+> ppr mod + ] + TcRnIdNotExportedFromLocalSig name + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the local signature." + ] + TcRnShadowedName occ provenance + -> let shadowed_locs = case provenance of + ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n] + ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres + in mkSimpleDecorated $ + sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + TcRnDuplicateWarningDecls d rdr_name + -> mkSimpleDecorated $ + vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLocA d)] + TcRnSimplifierTooManyIterations simples limit wc + -> mkSimpleDecorated $ + hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc + , text "Simples:" <+> ppr simples + ]) + TcRnIllegalPatSynDecl rdrname + -> mkSimpleDecorated $ + hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + TcRnLinearPatSyn ty + -> mkSimpleDecorated $ + hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty) + TcRnEmptyRecordUpdate + -> mkSimpleDecorated $ text "Empty record update" + TcRnIllegalFieldPunning fld + -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) + TcRnIllegalWildcardsInRecord fld_part + -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part + TcRnIllegalWildcardInType mb_name bad + -> mkSimpleDecorated $ case bad of + WildcardNotLastInConstraint -> + hang notAllowed 2 constraint_hint_msg + ExtraConstraintWildcardNotAllowed allow_sole -> + case allow_sole of + SoleExtraConstraintWildcardNotAllowed -> + notAllowed + SoleExtraConstraintWildcardAllowed -> + hang notAllowed 2 sole_msg + WildcardsNotAllowedAtAll -> + notAllowed + where + notAllowed, what, wildcard, how :: SDoc + notAllowed = what <+> quotes wildcard <+> how + wildcard = case mb_name of + Nothing -> pprAnonWildCard + Just name -> ppr name + what + | Just _ <- mb_name + = text "Named wildcard" + | ExtraConstraintWildcardNotAllowed {} <- bad + = text "Extra-constraint wildcard" + | otherwise + = text "Wildcard" + how = case bad of + WildcardNotLastInConstraint + -> text "not allowed in a constraint" + _ -> text "not allowed" + constraint_hint_msg :: SDoc + constraint_hint_msg + | Just _ <- mb_name + = vcat [ text "Extra-constraint wildcards must be anonymous" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + | otherwise + = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + sole_msg :: SDoc + sole_msg = + vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] + TcRnDuplicateFieldName fld_part dups + -> mkSimpleDecorated $ + hsep [text "duplicate field name", + quotes (ppr (NE.head dups)), + text "in record", pprRecordFieldPart fld_part] + TcRnIllegalViewPattern pat + -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] + TcRnCharLiteralOutOfRange c + -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' + TcRnIllegalWildcardsInConstructor con + -> mkSimpleDecorated $ + vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "The constructor has no labelled fields") ] + TcRnIgnoringAnnotations anns + -> mkSimpleDecorated $ + text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" + TcRnAnnotationInSafeHaskell + -> mkSimpleDecorated $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + TcRnInvalidTypeApplication fun_ty hs_ty + -> mkSimpleDecorated $ + text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ + text "to a visible type argument" <+> quotes (ppr hs_ty) + TcRnTagToEnumMissingValArg + -> mkSimpleDecorated $ + text "tagToEnum# must appear applied to one value argument" + TcRnTagToEnumUnspecifiedResTy ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ]) + TcRnTagToEnumResTyNotAnEnum ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type must be an enumeration type") + TcRnTagToEnumResTyTypeData ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type cannot be headed by a `type data` type") + TcRnArrowIfThenElsePredDependsOnResultTy + -> mkSimpleDecorated $ + text "Predicate type of `ifThenElse' depends on result type" + TcRnIllegalHsBootFileDecl + -> mkSimpleDecorated $ + text "Illegal declarations in an hs-boot file" + TcRnRecursivePatternSynonym binds + -> mkSimpleDecorated $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind . bagToList $ binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) + <+> pprLoc (locA loc) + TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty + -> mkSimpleDecorated $ + hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty + -> mkSimpleDecorated $ + hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (vcat [ hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) + , extra ]) + where + extra | Just rhs_ty <- m_unif_ty + = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] + | otherwise + = empty + TcRnMissingSignature what _ _ -> + mkSimpleDecorated $ + case what of + MissingPatSynSig p -> + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) + MissingTopLevelBindingSig name ty -> + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) + MissingTyConKindSig tc cusks_enabled -> + hang msg + 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) + where + msg | cusks_enabled + = text "Top-level type constructor with no standalone kind signature or CUSK:" + | otherwise + = text "Top-level type constructor with no standalone kind signature:" + + TcRnPolymorphicBinderMissingSig n ty + -> mkSimpleDecorated $ + sep [ text "Polymorphic local binding with no type signature:" + , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] + TcRnOverloadedSig sig + -> mkSimpleDecorated $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr sig) + TcRnTupleConstraintInst _ + -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint" + TcRnAbstractClassInst clas + -> mkSimpleDecorated $ + text "Cannot define instance for abstract class" <+> + quotes (ppr (className clas)) + TcRnNoClassInstHead tau + -> mkSimpleDecorated $ + hang (text "Instance head is not headed by a class:") 2 (pprType tau) + TcRnUserTypeError ty + -> mkSimpleDecorated (pprUserTypeErrorTy ty) + TcRnConstraintInKind ty + -> mkSimpleDecorated $ + text "Illegal constraint in a kind:" <+> pprType ty + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty + -> mkSimpleDecorated $ + sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:" + , pprType ty ] + where + what = case tuple_or_sum of + UnboxedTupleType -> text "tuple" + UnboxedSumType -> text "sum" + TcRnLinearFuncInKind ty + -> mkSimpleDecorated $ + text "Illegal linear function in a kind:" <+> pprType ty + TcRnForAllEscapeError ty kind + -> mkSimpleDecorated $ vcat + [ hang (text "Quantified type's kind mentions quantified type variable") + 2 (text "type:" <+> quotes (ppr ty)) + , hang (text "where the body of the forall has this kind:") + 2 (quotes (pprKind kind)) ] + TcRnVDQInTermType mb_ty + -> mkSimpleDecorated $ vcat + [ case mb_ty of + Nothing -> main_msg + Just ty -> hang (main_msg <> char ':') 2 (pprType ty) + , text "(GHC does not yet support this)" ] + where + main_msg = + text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + TcRnBadQuantPredHead ty + -> mkSimpleDecorated $ + hang (text "Quantified predicate must have a class or type variable head:") + 2 (pprType ty) + TcRnIllegalTupleConstraint ty + -> mkSimpleDecorated $ + text "Illegal tuple constraint:" <+> pprType ty + TcRnNonTypeVarArgInConstraint ty + -> mkSimpleDecorated $ + hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> pprType ty) + TcRnIllegalImplicitParam ty + -> mkSimpleDecorated $ + text "Illegal implicit parameter" <+> quotes (pprType ty) + TcRnIllegalConstraintSynonymOfKind kind + -> mkSimpleDecorated $ + text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind) + TcRnIllegalClassInst tcf + -> mkSimpleDecorated $ + vcat [ text "Illegal instance for a" <+> ppr tcf + , text "A class instance must be for a class" ] + TcRnOversaturatedVisibleKindArg ty + -> mkSimpleDecorated $ + text "Illegal oversaturated visible kind argument:" <+> + quotes (char '@' <> pprParendType ty) + TcRnBadAssociatedType clas tc + -> mkSimpleDecorated $ + hsep [ text "Class", quotes (ppr clas) + , text "does not have an associated type", quotes (ppr tc) ] + TcRnForAllRankErr rank ty + -> let herald = case tcSplitForAllTyVars ty of + ([], _) -> text "Illegal qualified type:" + _ -> text "Illegal polymorphic type:" + extra = case rank of + MonoTypeConstraint -> text "A constraint must be a monotype" + _ -> empty + in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra] + TcRnMonomorphicBindings bindings + -> let pp_bndrs = pprBindings bindings + in mkSimpleDecorated $ + sep [ text "The Monomorphism Restriction applies to the binding" + <> plural bindings + , text "for" <+> pp_bndrs ] + TcRnOrphanInstance inst + -> mkSimpleDecorated $ + hsep [ text "Orphan instance:" + , pprInstanceHdr inst + ] + TcRnFunDepConflict unit_state sorted + -> let herald = text "Functional dependencies conflict between instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnDupInstanceDecls unit_state sorted + -> let herald = text "Duplicate instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnConflictingFamInstDecls sortedNE + -> let sorted = NE.toList sortedNE + in mkSimpleDecorated $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) + TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns) + -> let (herald, show_kinds) = case rea of + InjErrRhsBareTyVar tys -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys, False) + InjErrRhsCannotBeATypeFam -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:", False) + InjErrRhsOverlap -> + (text "Type family equation right-hand sides overlap; this violates" $$ + text "the family's injectivity annotation:", False) + InjErrCannotInferFromRhs tvs has_kinds _ -> + let show_kinds = has_kinds == YesHasKinds + what = if show_kinds then text "Type/kind" else text "Type" + body = sep [ what <+> text "variable" <> + pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + , text "cannot be inferred from the right-hand side." ] + in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) + + in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $ + hang herald + 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) + TcRnBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnLazyBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnMultipleDefaultDeclarations dup_things + -> mkSimpleDecorated $ + hang (text "Multiple default declarations") + 2 (vcat (map pp dup_things)) + where + pp :: LDefaultDecl GhcRn -> SDoc + pp (L locn (DefaultDecl _ _)) + = text "here was another default declaration" <+> ppr (locA locn) + TcRnBadDefaultType ty deflt_clss + -> mkSimpleDecorated $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) + TcRnPatSynBundledWithNonDataCon + -> mkSimpleDecorated $ + text "Pattern synonyms can be bundled only with datatypes." + TcRnPatSynBundledWithWrongType expected_res_ty res_ty + -> mkSimpleDecorated $ + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + TcRnDupeModuleExport mod + -> mkSimpleDecorated $ + hsep [ text "Duplicate" + , quotes (text "Module" <+> ppr mod) + , text "in export list" ] + TcRnExportedModNotImported mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is not imported" + TcRnNullExportedModule mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "exports nothing" + TcRnMissingExportList mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is missing an export list" + TcRnExportHiddenComponents export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export constructors or class methods that are not visible here" + TcRnDuplicateExport child ie1 ie2 + -> mkSimpleDecorated $ + hsep [ quotes (ppr child) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnExportedParentChildMismatch parent_name ty_thing child parent_names + -> mkSimpleDecorated $ + text "The type constructor" <+> quotes (ppr parent_name) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + where + pp_category :: TyThing -> String + pp_category (AnId i) + | isRecordSelector i = "record selector" + pp_category i = tyThingCategory i + what_is = pp_category ty_thing + thing = ppr child + parents = map ppr parent_names + TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2 + -> mkSimpleDecorated $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export child1 gre1 ie1 + , ppr_export child2 gre2 ie2 + ] + where + ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr_name child)) + 2 (pprNameProvenance gre)) + + -- DuplicateRecordFields means that nameOccName might be a + -- mangled $sel-prefixed thing, in which case show the correct OccName + -- alone (but otherwise show the Name so it will have a module + -- qualifier) + ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl + | otherwise = ppr (flSelector fl) + ppr_name (NormalGreName name) = ppr name + TcRnAmbiguousField rupd parent_type + -> mkSimpleDecorated $ + vcat [ text "The record update" <+> ppr rupd + <+> text "with type" <+> ppr parent_type + <+> text "is ambiguous." + , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." + ] + TcRnMissingFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty + | otherwise = vcat (fmap pprField fields) + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" <> + if null fields then empty else colon + TcRnFieldUpdateInvalidType prs + -> mkSimpleDecorated $ + hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + TcRnNoConstructorHasAllFields conflictingFields + -> mkSimpleDecorated $ + hang (text "No constructor has all these fields:") + 2 (pprQuotedList conflictingFields) + TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels + -> mkSimpleDecorated $ + text "Cannot use a mixture of pattern synonym and record selectors" $$ + text "Record selectors defined by" + <+> quotes (ppr data_name) + <> colon + <+> pprWithCommas ppr data_sels $$ + text "Pattern synonym selectors defined by" + <+> quotes (ppr pat_name) + <> colon + <+> pprWithCommas ppr pat_syn_sels + TcRnMissingStrictFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty -- Happens for non-record constructors + -- with strict fields + | otherwise = vcat (fmap pprField fields) + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" <> + if null fields then empty else colon + TcRnNoPossibleParentForFields rbinds + -> mkSimpleDecorated $ + hang (text "No type has all these fields:") + 2 (pprQuotedList fields) + where fields = map (hfbLHS . unLoc) rbinds + TcRnBadOverloadedRecordUpdate _rbinds + -> mkSimpleDecorated $ + text "Record update is ambiguous, and requires a type signature" + TcRnStaticFormNotClosed name reason + -> mkSimpleDecorated $ + quotes (ppr name) + <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ sep (causes reason) + where + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + TcRnUselessTypeable + -> mkSimpleDecorated $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" + TcRnDerivingDefaults cls + -> mkSimpleDecorated $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + ] + TcRnNonUnaryTypeclassConstraint ct + -> mkSimpleDecorated $ + quotes (ppr ct) + <+> text "is not a unary constraint, as expected by a deriving clause" + TcRnPartialTypeSignatures _ theta + -> mkSimpleDecorated $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason + -> mkSimpleDecorated $ + derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason + TcRnLazyGADTPattern + -> mkSimpleDecorated $ + hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") + TcRnArrowProcGADTPattern + -> mkSimpleDecorated $ + text "Proc patterns cannot use existential or GADT data constructors" + + TcRnSpecialClassInst cls because_safeHaskell + -> mkSimpleDecorated $ + text "Class" <+> quotes (ppr $ className cls) + <+> text "does not support user-specified instances" + <> safeHaskell_msg + where + safeHaskell_msg + | because_safeHaskell + = text " when Safe Haskell is enabled." + | otherwise + = dot + TcRnForallIdentifier rdr_name + -> mkSimpleDecorated $ + fsep [ text "The use of" <+> quotes (ppr rdr_name) + <+> text "as an identifier", + text "will become an error in a future GHC release." ] + TcRnTypeEqualityOutOfScope + -> mkDecorated + [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$ + text "Assuming it to stand for an equality constraint." + , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$ + text "exported from Data.Type.Equality and Prelude.") $$ + text "If you are using a custom Prelude, consider re-exporting it." + , text "This will become an error in a future GHC release." ] + TcRnTypeEqualityRequiresOperators + -> mkSimpleDecorated $ + fsep [ text "The use of" <+> quotes (text "~") + <+> text "without TypeOperators", + text "will become an error in a future GHC release." ] + TcRnIllegalTypeOperator overall_ty op + -> mkSimpleDecorated $ + text "Illegal operator" <+> quotes (ppr op) <+> + text "in type" <+> quotes (ppr overall_ty) + TcRnIllegalTypeOperatorDecl name + -> mkSimpleDecorated $ + text "Illegal declaration of a type or class operator" <+> quotes (ppr name) + TcRnGADTMonoLocalBinds + -> mkSimpleDecorated $ + fsep [ text "Pattern matching on GADTs without MonoLocalBinds" + , text "is fragile." ] + TcRnIncorrectNameSpace name _ + -> mkSimpleDecorated $ msg + where + msg + -- We are in a type-level namespace, + -- and the name is incorrectly at the term-level. + | isValNameSpace ns + = text "The" <+> what <+> text "does not live in the type-level namespace" + + -- We are in a term-level namespace, + -- and the name is incorrectly at the type-level. + | otherwise + = text "Illegal term-level use of the" <+> what + ns = nameNameSpace name + what = pprNameSpace ns <+> quotes (ppr name) + TcRnNotInScope err name imp_errs _ + -> mkSimpleDecorated $ + pprScopeError name err $$ vcat (map ppr imp_errs) + TcRnUntickedPromotedThing thing + -> mkSimpleDecorated $ + text "Unticked promoted" <+> what + where + what :: SDoc + what = case thing of + UntickedExplicitList -> text "list" <> dot + UntickedConstructor fixity nm -> + let con = pprUntickedConstructor fixity nm + bare_sym = isBareSymbol fixity nm + in text "constructor:" <+> con <> if bare_sym then empty else dot + TcRnIllegalBuiltinSyntax what rdr_name + -> mkSimpleDecorated $ + hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name] + TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + -> mkSimpleDecorated $ + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) + 2 + (pprWithArising tidy_wanteds) + + + TcRnForeignImportPrimExtNotSet _decl + -> mkSimpleDecorated $ + text "`foreign import prim' requires GHCForeignImportPrim." + + TcRnForeignImportPrimSafeAnn _decl + -> mkSimpleDecorated $ + text "The safe/unsafe annotation should not be used with `foreign import prim'." + + TcRnForeignFunctionImportAsValue _decl + -> mkSimpleDecorated $ + text "`value' imports cannot have function types" + + TcRnFunPtrImportWithoutAmpersand _decl + -> mkSimpleDecorated $ + text "possible missing & in foreign import of FunPtr" + + TcRnIllegalForeignDeclBackend _decl _backend expectedBknds + -> mkSimpleDecorated $ + fsep (text "Illegal foreign declaration: requires one of these back ends:" : + commafyWith (text "or") (map (text . backendDescription) expectedBknds)) + + TcRnUnsupportedCallConv _decl unsupportedCC + -> mkSimpleDecorated $ + case unsupportedCC of + StdCallConvUnsupported -> + text "the 'stdcall' calling convention is unsupported on this platform," + $$ text "treating as ccall" + PrimCallConvUnsupported -> + text "The `prim' calling convention can only be used with `foreign import'" + JavaScriptCallConvUnsupported -> + text "The `javascript' calling convention is unsupported on this platform" + + TcRnIllegalForeignType mArgOrResult reason + -> mkSimpleDecorated $ hang msg 2 extra + where + arg_or_res = case mArgOrResult of + Nothing -> empty + Just Arg -> text "argument" + Just Result -> text "result" + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + extra = + case reason of + TypeCannotBeMarshaled ty why -> + let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + in case why of + NotADataType -> + quotes (ppr ty) <+> text "is not a data type" + NewtypeDataConNotInScope Nothing -> + hang innerMsg 2 $ text "because its data constructor is not in scope" + NewtypeDataConNotInScope (Just tc) -> + hang innerMsg 2 $ + text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + UnliftedFFITypesNeeded -> + innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types" + NotABoxedMarshalableTyCon -> innerMsg + ForeignLabelNotAPtr -> + innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" + NotSimpleUnliftedType -> + innerMsg $$ text "foreign import prim only accepts simple unlifted types" + NotBoxedKindAny -> + text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$ + text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty)) + ForeignDynNotPtr expected ty -> + vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] + SafeHaskellMustBeInIO -> + text "Safe Haskell is on, all FFI imports must be in the IO monad" + IOResultExpected -> + text "IO result type expected" + UnexpectedNestedForall -> + text "Unexpected nested forall" + LinearTypesNotAllowed -> + text "Linear types are not supported in FFI declarations, see #18472" + OneArgExpected -> + text "One argument expected" + AtLeastOneArgExpected -> + text "At least one argument expected" + TcRnInvalidCIdentifier target + -> mkSimpleDecorated $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] + TcRnExpectedValueId thing + -> mkSimpleDecorated $ + ppr thing <+> text "used where a value identifier was expected" + TcRnNotARecordSelector field + -> mkSimpleDecorated $ + hsep [quotes (ppr field), text "is not a record selector"] + TcRnRecSelectorEscapedTyVar lbl + -> mkSimpleDecorated $ + text "Cannot use record selector" <+> quotes (ppr lbl) <+> + text "as a function due to escaped type variables" + TcRnPatSynNotBidirectional name + -> mkSimpleDecorated $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" + TcRnSplicePolymorphicLocalVar ident + -> mkSimpleDecorated $ + text "Can't splice the polymorphic local variable" <+> quotes (ppr ident) + TcRnIllegalDerivingItem hs_ty + -> mkSimpleDecorated $ + text "Illegal deriving item" <+> quotes (ppr hs_ty) + TcRnUnexpectedAnnotation ty bang + -> mkSimpleDecorated $ + let err = case bang of + HsSrcBang _ SrcUnpack _ -> "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness" + HsSrcBang _ _ _ -> "strictness" + in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation cannot appear nested inside a type" + TcRnIllegalRecordSyntax ty + -> mkSimpleDecorated $ + text "Record syntax is illegal here:" <+> ppr ty + TcRnUnexpectedTypeSplice ty + -> mkSimpleDecorated $ + text "Unexpected type splice:" <+> ppr ty + TcRnInvalidVisibleKindArgument arg ty + -> mkSimpleDecorated $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + TcRnTooManyBinders ki bndrs + -> mkSimpleDecorated $ + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + TcRnDifferentNamesForTyVar n1 n2 + -> mkSimpleDecorated $ + hang (text "Different names for the same type variable:") 2 info + where + info | nameOccName n1 /= nameOccName n2 + = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) + | otherwise -- Same OccNames! See C2 in + -- Note [Swizzling the tyvars before generaliseTcTyCon] + = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) + , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext + -> mkSimpleDecorated $ + sep [ ppDataSort data_sort <+> + text "has non-" <> + allowed_kind_tycon + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) + ] + where + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + allowed_kind_tycon = + case allowed_kind of + AnyTYPEKind -> ppr tYPETyCon + AnyBoxedKind -> ppr boxedRepDataConTyCon + LiftedKind -> ppr liftedTypeKind + TcRnClassKindNotConstraint _kind + -> mkSimpleDecorated $ + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + TcRnUnpromotableThing name err + -> mkSimpleDecorated $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE pred + -> text "it has an unpromotable context" + <+> quotes (ppr pred) + FamDataConPE -> text "it comes from a data family instance" + NoDataKindsDC -> text "perhaps you intended to use DataKinds" + PatSynPE -> text "pattern synonyms cannot be promoted" + RecDataConPE -> same_rec_group_msg + ClassPE -> same_rec_group_msg + TyConPE -> same_rec_group_msg + TermVariablePE -> text "term variables cannot be promoted" + same_rec_group_msg = text "it is defined and used in the same recursive group" + TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches) + -> mkSimpleDecorated $ + (vcat [ pprMatchContextNouns argsContext <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (NE.head bad_matches)))]) + TcRnCannotBindScopedTyVarInPatSig sig_tvs + -> mkSimpleDecorated $ + hang (text "You cannot bind scoped type variable" + <> plural (NE.toList sig_tvs) + <+> pprQuotedList (map fst $ NE.toList sig_tvs)) + 2 (text "in a pattern binding signature") + TcRnCannotBindTyVarsInPatBind _offenders + -> mkSimpleDecorated $ + text "Binding type variables is not allowed in pattern bindings" + TcRnTooManyTyArgsInConPattern con_like expected_number actual_number + -> mkSimpleDecorated $ + text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ + text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number + TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags + -> mkSimpleDecorated $ + hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (fst_inl_prag : NE.toList inl_prags))) + where + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + TcRnUnexpectedPragmas poly_id bad_sigs + -> mkSimpleDecorated $ + hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs)) + TcRnNonOverloadedSpecialisePragma fun_name + -> mkSimpleDecorated $ + text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name) + TcRnSpecialiseNotVisible name + -> mkSimpleDecorated $ + text "You cannot SPECIALISE" <+> quotes (ppr name) + <+> text "because its definition is not visible in this module" + TcRnNameByTemplateHaskellQuote name -> mkSimpleDecorated $ + text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name + TcRnIllegalBindingOfBuiltIn name -> mkSimpleDecorated $ + text "Illegal binding of built-in syntax:" <+> ppr name + TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod} + -> mkSimpleDecorated $ + sep [ sep [ text "In the use of" + <+> pprNonVarNameSpace (occNameSpace pragma_warning_occ) + <+> quotes (ppr pragma_warning_occ) + , parens impMsg <> colon ] + , pprWarningTxtForMsg pragma_warning_msg ] + where + impMsg = text "imported from" <+> ppr pragma_warning_import_mod <> extra + extra | pragma_warning_import_mod == pragma_warning_defined_mod = empty + | otherwise = text ", but defined in" <+> ppr pragma_warning_defined_mod + TcRnIllegalHsigDefaultMethods name meths + -> mkSimpleDecorated $ + text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file" + TcRnBadGenericMethod clas op + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + TcRnWarningMinimalDefIncomplete mindef + -> mkSimpleDecorated $ + vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + TcRnDefaultMethodForPragmaLacksBinding sel_id prag + -> mkSimpleDecorated $ + text "The" <+> hsSigDoc prag <+> text "for default method" + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding" + TcRnIgnoreSpecialisePragmaOnDefMethod sel_name + -> mkSimpleDecorated $ + text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name) + TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName} + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr badMethodErrClassName), + text "does not have a method", quotes (ppr badMethodErrMethodName)] + TcRnNoExplicitAssocTypeOrDefaultDeclaration name + -> mkSimpleDecorated $ + text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name) + TcRnIllegalTypeData + -> mkSimpleDecorated $ + text "Illegal type-level data declaration" + TcRnTypeDataForbids feature + -> mkSimpleDecorated $ + ppr feature <+> text "are not allowed in type data declarations." + + TcRnIllegalNewtype con show_linear_types reason + -> mkSimpleDecorated $ + vcat [msg, additional] + where + (msg,additional) = + case reason of + DoesNotHaveSingleField n_flds -> + (sep [ + text "A newtype constructor must have exactly one field", + nest 2 $ + text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds + ], + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + IsNonLinear -> + (text "A newtype constructor must be linear", + 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)) + HasConstructorContext -> + (text "A newtype constructor must not have a context in its type", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasExistentialTyVar -> + (text "A newtype constructor must not have existential type variables", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasStrictnessAnnotation -> + (text "A newtype constructor must not have a strictness annotation", empty) + + -- 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 + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + TcRnSpliceThrewException phase _exn exn_msg expr show_code + -> mkSimpleDecorated $ + vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:" + , nest 2 (text exn_msg) + , if show_code then text "Code:" <+> ppr expr else empty] + where phaseStr = + case phase of + SplicePhase_Run -> "run" + SplicePhase_CompileAndLink -> "compile and link" + TcRnInvalidTopDecl _decl + -> mkSimpleDecorated $ + text "Only function, value, annotation, and foreign import declarations may be added with addTopDecls" + TcRnNonExactName name + -> mkSimpleDecorated $ + hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + TcRnAddInvalidCorePlugin plugin + -> mkSimpleDecorated $ + hang + (text "addCorePlugin: invalid plugin module " + <+> text (show plugin) + ) + 2 + (text "Plugins in the current package can't be specified.") + TcRnAddDocToNonLocalDefn doc_loc + -> mkSimpleDecorated $ + text "Can't add documentation to" <+> ppr_loc doc_loc <+> + text "as it isn't inside the current module" + where + ppr_loc (TH.DeclDoc n) = text $ TH.pprint n + ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n + ppr_loc (TH.InstDoc t) = text $ TH.pprint t + ppr_loc TH.ModuleDoc = text "the module header" + + TcRnFailedToLookupThInstName th_type reason + -> mkSimpleDecorated $ + case reason of + NoMatchesFound -> + text "Couldn't find any instances of" + <+> text (TH.pprint th_type) + <+> text "to add documentation to" + CouldNotDetermineInstance -> + text "Couldn't work out what instance" + <+> text (TH.pprint th_type) + <+> text "is supposed to be" + TcRnCannotReifyInstance ty + -> mkSimpleDecorated $ + hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application") + TcRnCannotReifyOutOfScopeThing th_name + -> mkSimpleDecorated $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + TcRnCannotReifyThingNotInTypeEnv name + -> mkSimpleDecorated $ + quotes (ppr name) <+> text "is not in the type environment at a reify" + TcRnNoRolesAssociatedWithThing thing + -> mkSimpleDecorated $ + text "No roles associated with" <+> (ppr thing) + TcRnCannotRepresentType sort ty + -> mkSimpleDecorated $ + hsep [text "Can't represent" <+> sort_doc <+> + text "in Template Haskell:", + nest 2 (ppr ty)] + where + sort_doc = text $ + case sort of + LinearInvisibleArgument -> "linear invisible argument" + CoercionsInTypes -> "coercions in types" + TcRnRunSpliceFailure mCallingFnName (ConversionFail what reason) + -> mkSimpleDecorated + . addCallingFn + . addSpliceInfo + $ pprConversionFailReason reason + where + addCallingFn rest = + case mCallingFnName of + Nothing -> rest + Just callingFn -> + hang (text ("Error in a declaration passed to " ++ callingFn ++ ":")) + 2 rest + addSpliceInfo = case what of + ConvDec d -> addSliceInfo' "declaration" d + ConvExp e -> addSliceInfo' "expression" e + ConvPat p -> addSliceInfo' "pattern" p + ConvType t -> addSliceInfo' "type" t + addSliceInfo' what item reasonErr = reasonErr $$ descr + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + descr = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (TH.pprint item)) + TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg + TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc + TcRnUnsatisfiedMinimalDef mindef + -> mkSimpleDecorated $ + vcat [text "No explicit implementation for" + ,nest 2 $ pprBooleanFormulaNice mindef + ] + TcRnMisplacedInstSig name hs_ty + -> mkSimpleDecorated $ + vcat [ hang (text "Illegal type signature in instance declaration:") + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + ] + TcRnBadBootFamInstDecl {} + -> mkSimpleDecorated $ + text "Illegal family instance in hs-boot file" + TcRnIllegalFamilyInstance tycon + -> mkSimpleDecorated $ + vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] + TcRnMissingClassAssoc name + -> mkSimpleDecorated $ + text "Associated type" <+> quotes (ppr name) <+> + text "must be inside a class instance" + TcRnBadFamInstDecl tc_name + -> mkSimpleDecorated $ + text "Illegal family instance for" <+> quotes (ppr tc_name) + TcRnNotOpenFamily tc + -> mkSimpleDecorated $ + text "Illegal instance for closed family" <+> quotes (ppr tc) + TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $ + text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $ + text "For this to work enable NamedFieldPuns" + TcRnIllegalStaticExpression e -> mkSimpleDecorated $ + text "Illegal static expression:" <+> ppr e + TcRnIllegalStaticFormInSplice e -> mkSimpleDecorated $ + sep [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $ + (text "Duplicate binding in parallel list comprehension for:" + <+> quotes (ppr n)) + TcRnEmptyStmtsGroup cause -> mkSimpleDecorated $ case cause of + EmptyStmtsGroupInParallelComp -> + text "Empty statement group in parallel comprehension" + EmptyStmtsGroupInTransformListComp -> + text "Empty statement group preceding 'group' or 'then'" + EmptyStmtsGroupInDoNotation ctxt -> + text "Empty" <+> pprHsDoFlavour ctxt + EmptyStmtsGroupInArrowNotation -> + text "Empty 'do' block in an arrow command" + TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) -> + mkSimpleDecorated $ hang last_error 2 (ppr stmt) + where + last_error = + text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression" + TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $ + sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" + , text "in" <+> pprAStmtContext ctxt ] + TcRnIllegalTupleSection -> mkSimpleDecorated $ + text "Illegal tuple section" + TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $ + either msg msg eBinds + where + msg binds = hang + (text "Implicit-parameter bindings illegal in an mdo expression") + 2 (ppr binds) + TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $ + hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) + + TcRnLoopySuperclassSolve wtd_loc wtd_pty -> + mkSimpleDecorated $ vcat [ header, warning, user_manual ] + where + header, warning, user_manual :: SDoc + header + = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma + , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma + , text "in a way that might turn out to loop at runtime." ] + warning + = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ] + user_manual = + vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ] + + diagnosticReason = \case + TcRnUnknownMessage m + -> diagnosticReason m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticReason m + TcRnWithHsDocContext _ msg + -> diagnosticReason msg + TcRnSolverReport _ reason _ + -> reason -- Error, or a Warning if we are deferring type errors + TcRnRedundantConstraints {} + -> WarningWithFlag Opt_WarnRedundantConstraints + TcRnInaccessibleCode {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> ErrorWithoutFlag + TcRnImplicitLift{} + -> WarningWithFlag Opt_WarnImplicitLift + TcRnUnusedPatternBinds{} + -> WarningWithFlag Opt_WarnUnusedPatternBinds + TcRnDodgyImports{} + -> WarningWithFlag Opt_WarnDodgyImports + TcRnDodgyExports{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + TcRnUnsafeDueToPlugin{} + -> WarningWithoutFlag + TcRnModMissingRealSrcSpan{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromModuleSig{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromLocalSig{} + -> ErrorWithoutFlag + TcRnShadowedName{} + -> WarningWithFlag Opt_WarnNameShadowing + TcRnDuplicateWarningDecls{} + -> ErrorWithoutFlag + TcRnSimplifierTooManyIterations{} + -> ErrorWithoutFlag + TcRnIllegalPatSynDecl{} + -> ErrorWithoutFlag + TcRnLinearPatSyn{} + -> ErrorWithoutFlag + TcRnEmptyRecordUpdate + -> ErrorWithoutFlag + TcRnIllegalFieldPunning{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInRecord{} + -> ErrorWithoutFlag + TcRnIllegalWildcardInType{} + -> ErrorWithoutFlag + TcRnDuplicateFieldName{} + -> ErrorWithoutFlag + TcRnIllegalViewPattern{} + -> ErrorWithoutFlag + TcRnCharLiteralOutOfRange{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInConstructor{} + -> ErrorWithoutFlag + TcRnIgnoringAnnotations{} + -> WarningWithoutFlag + TcRnAnnotationInSafeHaskell + -> ErrorWithoutFlag + TcRnInvalidTypeApplication{} + -> ErrorWithoutFlag + TcRnTagToEnumMissingValArg + -> ErrorWithoutFlag + TcRnTagToEnumUnspecifiedResTy{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyNotAnEnum{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyTypeData{} + -> ErrorWithoutFlag + TcRnArrowIfThenElsePredDependsOnResultTy + -> ErrorWithoutFlag + TcRnIllegalHsBootFileDecl + -> ErrorWithoutFlag + TcRnRecursivePatternSynonym{} + -> ErrorWithoutFlag + TcRnPartialTypeSigTyVarMismatch{} + -> ErrorWithoutFlag + TcRnPartialTypeSigBadQuantifier{} + -> ErrorWithoutFlag + TcRnMissingSignature what exported overridden + -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden + TcRnPolymorphicBinderMissingSig{} + -> WarningWithFlag Opt_WarnMissingLocalSignatures + TcRnOverloadedSig{} + -> ErrorWithoutFlag + TcRnTupleConstraintInst{} + -> ErrorWithoutFlag + TcRnAbstractClassInst{} + -> ErrorWithoutFlag + TcRnNoClassInstHead{} + -> ErrorWithoutFlag + TcRnUserTypeError{} + -> ErrorWithoutFlag + TcRnConstraintInKind{} + -> ErrorWithoutFlag + TcRnUnboxedTupleOrSumTypeFuncArg{} + -> ErrorWithoutFlag + TcRnLinearFuncInKind{} + -> ErrorWithoutFlag + TcRnForAllEscapeError{} + -> ErrorWithoutFlag + TcRnVDQInTermType{} + -> ErrorWithoutFlag + TcRnBadQuantPredHead{} + -> ErrorWithoutFlag + TcRnIllegalTupleConstraint{} + -> ErrorWithoutFlag + TcRnNonTypeVarArgInConstraint{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParam{} + -> ErrorWithoutFlag + TcRnIllegalConstraintSynonymOfKind{} + -> ErrorWithoutFlag + TcRnIllegalClassInst{} + -> ErrorWithoutFlag + TcRnOversaturatedVisibleKindArg{} + -> ErrorWithoutFlag + TcRnBadAssociatedType{} + -> ErrorWithoutFlag + TcRnForAllRankErr{} + -> ErrorWithoutFlag + TcRnMonomorphicBindings{} + -> WarningWithFlag Opt_WarnMonomorphism + TcRnOrphanInstance{} + -> WarningWithFlag Opt_WarnOrphans + TcRnFunDepConflict{} + -> ErrorWithoutFlag + TcRnDupInstanceDecls{} + -> ErrorWithoutFlag + TcRnConflictingFamInstDecls{} + -> ErrorWithoutFlag + TcRnFamInstNotInjective{} + -> ErrorWithoutFlag + TcRnBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnLazyBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnMultipleDefaultDeclarations{} + -> ErrorWithoutFlag + TcRnBadDefaultType{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithNonDataCon{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithWrongType{} + -> ErrorWithoutFlag + TcRnDupeModuleExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedModNotImported{} + -> ErrorWithoutFlag + TcRnNullExportedModule{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingExportList{} + -> WarningWithFlag Opt_WarnMissingExportList + TcRnExportHiddenComponents{} + -> ErrorWithoutFlag + TcRnDuplicateExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedParentChildMismatch{} + -> ErrorWithoutFlag + TcRnConflictingExports{} + -> ErrorWithoutFlag + TcRnAmbiguousField{} + -> WarningWithFlag Opt_WarnAmbiguousFields + TcRnMissingFields{} + -> WarningWithFlag Opt_WarnMissingFields + TcRnFieldUpdateInvalidType{} + -> ErrorWithoutFlag + TcRnNoConstructorHasAllFields{} + -> ErrorWithoutFlag + TcRnMixedSelectors{} + -> ErrorWithoutFlag + TcRnMissingStrictFields{} + -> ErrorWithoutFlag + TcRnNoPossibleParentForFields{} + -> ErrorWithoutFlag + TcRnBadOverloadedRecordUpdate{} + -> ErrorWithoutFlag + TcRnStaticFormNotClosed{} + -> ErrorWithoutFlag + TcRnUselessTypeable + -> WarningWithFlag Opt_WarnDerivingTypeable + TcRnDerivingDefaults{} + -> WarningWithFlag Opt_WarnDerivingDefaults + TcRnNonUnaryTypeclassConstraint{} + -> ErrorWithoutFlag + TcRnPartialTypeSignatures{} + -> WarningWithFlag Opt_WarnPartialTypeSignatures + TcRnCannotDeriveInstance _ _ _ _ rea + -> case rea of + DerivErrNotWellKinded{} -> ErrorWithoutFlag + DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag + DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag + DerivErrNoEtaReduce{} -> ErrorWithoutFlag + DerivErrBootFileFound -> ErrorWithoutFlag + DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag + DerivErrGNDUsedOnData -> ErrorWithoutFlag + DerivErrNullaryClasses -> ErrorWithoutFlag + DerivErrLastArgMustBeApp -> ErrorWithoutFlag + DerivErrNoFamilyInstance{} -> ErrorWithoutFlag + DerivErrNotStockDeriveable{} -> ErrorWithoutFlag + DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag + DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag + DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag + DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag + DerivErrNotDeriveable{} -> ErrorWithoutFlag + DerivErrNotAClass{} -> ErrorWithoutFlag + DerivErrNoConstructors{} -> ErrorWithoutFlag + DerivErrLangExtRequired{} -> ErrorWithoutFlag + DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag + DerivErrMustBeEnumType{} -> ErrorWithoutFlag + DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag + DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag + DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag + DerivErrBadConstructor{} -> ErrorWithoutFlag + DerivErrGenerics{} -> ErrorWithoutFlag + DerivErrEnumOrProduct{} -> ErrorWithoutFlag + TcRnLazyGADTPattern + -> ErrorWithoutFlag + TcRnArrowProcGADTPattern + -> ErrorWithoutFlag + TcRnSpecialClassInst {} + -> ErrorWithoutFlag + TcRnForallIdentifier {} + -> WarningWithFlag Opt_WarnForallIdentifier + TcRnTypeEqualityOutOfScope + -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope + TcRnTypeEqualityRequiresOperators + -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators + TcRnIllegalTypeOperator {} + -> ErrorWithoutFlag + TcRnIllegalTypeOperatorDecl {} + -> ErrorWithoutFlag + TcRnGADTMonoLocalBinds {} + -> WarningWithFlag Opt_WarnGADTMonoLocalBinds + TcRnIncorrectNameSpace {} + -> ErrorWithoutFlag + TcRnNotInScope {} + -> ErrorWithoutFlag + TcRnUntickedPromotedThing {} + -> WarningWithFlag Opt_WarnUntickedPromotedConstructors + TcRnIllegalBuiltinSyntax {} + -> ErrorWithoutFlag + TcRnWarnDefaulting {} + -> WarningWithFlag Opt_WarnTypeDefaults + TcRnForeignImportPrimExtNotSet{} + -> ErrorWithoutFlag + TcRnForeignImportPrimSafeAnn{} + -> ErrorWithoutFlag + TcRnForeignFunctionImportAsValue{} + -> ErrorWithoutFlag + TcRnFunPtrImportWithoutAmpersand{} + -> WarningWithFlag Opt_WarnDodgyForeignImports + TcRnIllegalForeignDeclBackend{} + -> ErrorWithoutFlag + TcRnUnsupportedCallConv _ unsupportedCC + -> case unsupportedCC of + StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions + _ -> ErrorWithoutFlag + TcRnIllegalForeignType{} + -> ErrorWithoutFlag + TcRnInvalidCIdentifier{} + -> ErrorWithoutFlag + TcRnExpectedValueId{} + -> ErrorWithoutFlag + TcRnNotARecordSelector{} + -> ErrorWithoutFlag + TcRnRecSelectorEscapedTyVar{} + -> ErrorWithoutFlag + TcRnPatSynNotBidirectional{} + -> ErrorWithoutFlag + TcRnSplicePolymorphicLocalVar{} + -> ErrorWithoutFlag + TcRnIllegalDerivingItem{} + -> ErrorWithoutFlag + TcRnUnexpectedAnnotation{} + -> ErrorWithoutFlag + TcRnIllegalRecordSyntax{} + -> ErrorWithoutFlag + TcRnUnexpectedTypeSplice{} + -> ErrorWithoutFlag + TcRnInvalidVisibleKindArgument{} + -> ErrorWithoutFlag + TcRnTooManyBinders{} + -> ErrorWithoutFlag + TcRnDifferentNamesForTyVar{} + -> ErrorWithoutFlag + TcRnInvalidReturnKind{} + -> ErrorWithoutFlag + TcRnClassKindNotConstraint{} + -> ErrorWithoutFlag + TcRnUnpromotableThing{} + -> ErrorWithoutFlag + TcRnMatchesHaveDiffNumArgs{} + -> ErrorWithoutFlag + TcRnCannotBindScopedTyVarInPatSig{} + -> ErrorWithoutFlag + TcRnCannotBindTyVarsInPatBind{} + -> ErrorWithoutFlag + TcRnTooManyTyArgsInConPattern{} + -> ErrorWithoutFlag + TcRnMultipleInlinePragmas{} + -> WarningWithoutFlag + TcRnUnexpectedPragmas{} + -> WarningWithoutFlag + TcRnNonOverloadedSpecialisePragma{} + -> WarningWithoutFlag + TcRnSpecialiseNotVisible{} + -> WarningWithoutFlag + TcRnNameByTemplateHaskellQuote{} + -> ErrorWithoutFlag + TcRnIllegalBindingOfBuiltIn{} + -> ErrorWithoutFlag + TcRnPragmaWarning{} + -> WarningWithFlag Opt_WarnWarningsDeprecations + TcRnIllegalHsigDefaultMethods{} + -> ErrorWithoutFlag + TcRnBadGenericMethod{} + -> ErrorWithoutFlag + TcRnWarningMinimalDefIncomplete{} + -> WarningWithoutFlag + TcRnDefaultMethodForPragmaLacksBinding{} + -> ErrorWithoutFlag + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> WarningWithoutFlag + TcRnBadMethodErr{} + -> ErrorWithoutFlag + TcRnNoExplicitAssocTypeOrDefaultDeclaration{} + -> WarningWithFlag (Opt_WarnMissingMethods) + TcRnIllegalTypeData + -> ErrorWithoutFlag + TcRnTypeDataForbids{} + -> ErrorWithoutFlag + TcRnIllegalNewtype{} + -> ErrorWithoutFlag + TcRnTypedTHWithPolyType{} + -> ErrorWithoutFlag + TcRnSpliceThrewException{} + -> ErrorWithoutFlag + TcRnInvalidTopDecl{} + -> ErrorWithoutFlag + TcRnNonExactName{} + -> ErrorWithoutFlag + TcRnAddInvalidCorePlugin{} + -> ErrorWithoutFlag + TcRnAddDocToNonLocalDefn{} + -> ErrorWithoutFlag + TcRnFailedToLookupThInstName{} + -> ErrorWithoutFlag + TcRnCannotReifyInstance{} + -> ErrorWithoutFlag + TcRnCannotReifyOutOfScopeThing{} + -> ErrorWithoutFlag + TcRnCannotReifyThingNotInTypeEnv{} + -> ErrorWithoutFlag + TcRnNoRolesAssociatedWithThing{} + -> ErrorWithoutFlag + TcRnCannotRepresentType{} + -> ErrorWithoutFlag + TcRnRunSpliceFailure{} + -> ErrorWithoutFlag + TcRnReportCustomQuasiError isError _ + -> if isError then ErrorWithoutFlag else WarningWithoutFlag + TcRnInterfaceLookupError{} + -> ErrorWithoutFlag + TcRnUnsatisfiedMinimalDef{} + -> WarningWithFlag (Opt_WarnMissingMethods) + TcRnMisplacedInstSig{} + -> ErrorWithoutFlag + TcRnBadBootFamInstDecl{} + -> ErrorWithoutFlag + TcRnIllegalFamilyInstance{} + -> ErrorWithoutFlag + TcRnMissingClassAssoc{} + -> ErrorWithoutFlag + TcRnBadFamInstDecl{} + -> ErrorWithoutFlag + TcRnNotOpenFamily{} + -> ErrorWithoutFlag + TcRnNoRebindableSyntaxRecordDot{} + -> ErrorWithoutFlag + TcRnNoFieldPunsRecordDot{} + -> ErrorWithoutFlag + TcRnIllegalStaticExpression{} + -> ErrorWithoutFlag + TcRnIllegalStaticFormInSplice{} + -> ErrorWithoutFlag + TcRnListComprehensionDuplicateBinding{} + -> ErrorWithoutFlag + TcRnEmptyStmtsGroup{} + -> ErrorWithoutFlag + TcRnLastStmtNotExpr{} + -> ErrorWithoutFlag + TcRnUnexpectedStatementInContext{} + -> ErrorWithoutFlag + TcRnSectionWithoutParentheses{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParameterBindings{} + -> ErrorWithoutFlag + TcRnIllegalTupleSection{} + -> ErrorWithoutFlag + TcRnLoopySuperclassSolve{} + -> WarningWithFlag Opt_WarnLoopySuperclassSolve + + diagnosticHints = \case + TcRnUnknownMessage m + -> diagnosticHints m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticHints m + TcRnWithHsDocContext _ msg + -> diagnosticHints msg + TcRnSolverReport _ _ hints + -> hints + TcRnRedundantConstraints{} + -> noHints + TcRnInaccessibleCode{} + -> noHints + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> noHints + TcRnImplicitLift{} + -> noHints + TcRnUnusedPatternBinds{} + -> noHints + TcRnDodgyImports{} + -> noHints + TcRnDodgyExports{} + -> noHints + TcRnMissingImportList{} + -> noHints + TcRnUnsafeDueToPlugin{} + -> noHints + TcRnModMissingRealSrcSpan{} + -> noHints + TcRnIdNotExportedFromModuleSig name mod + -> [SuggestAddToHSigExportList name $ Just mod] + TcRnIdNotExportedFromLocalSig name + -> [SuggestAddToHSigExportList name Nothing] + TcRnShadowedName{} + -> noHints + TcRnDuplicateWarningDecls{} + -> noHints + TcRnSimplifierTooManyIterations{} + -> [SuggestIncreaseSimplifierIterations] + TcRnIllegalPatSynDecl{} + -> noHints + TcRnLinearPatSyn{} + -> noHints + TcRnEmptyRecordUpdate{} + -> noHints + TcRnIllegalFieldPunning{} + -> [suggestExtension LangExt.NamedFieldPuns] + TcRnIllegalWildcardsInRecord{} + -> [suggestExtension LangExt.RecordWildCards] + TcRnIllegalWildcardInType{} + -> noHints + TcRnDuplicateFieldName{} + -> noHints + TcRnIllegalViewPattern{} + -> [suggestExtension LangExt.ViewPatterns] + TcRnCharLiteralOutOfRange{} + -> noHints + TcRnIllegalWildcardsInConstructor{} + -> noHints + TcRnIgnoringAnnotations{} + -> noHints + TcRnAnnotationInSafeHaskell + -> noHints + TcRnInvalidTypeApplication{} + -> noHints + TcRnTagToEnumMissingValArg + -> noHints + TcRnTagToEnumUnspecifiedResTy{} + -> noHints + TcRnTagToEnumResTyNotAnEnum{} + -> noHints + TcRnTagToEnumResTyTypeData{} + -> noHints + TcRnArrowIfThenElsePredDependsOnResultTy + -> noHints + TcRnIllegalHsBootFileDecl + -> noHints + TcRnRecursivePatternSynonym{} + -> noHints + TcRnPartialTypeSigTyVarMismatch{} + -> noHints + TcRnPartialTypeSigBadQuantifier{} + -> noHints + TcRnMissingSignature {} + -> noHints + TcRnPolymorphicBinderMissingSig{} + -> noHints + TcRnOverloadedSig{} + -> noHints + TcRnTupleConstraintInst{} + -> noHints + TcRnAbstractClassInst{} + -> noHints + TcRnNoClassInstHead{} + -> noHints + TcRnUserTypeError{} + -> noHints + TcRnConstraintInKind{} + -> noHints + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _ + -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum] + TcRnLinearFuncInKind{} + -> noHints + TcRnForAllEscapeError{} + -> noHints + TcRnVDQInTermType{} + -> noHints + TcRnBadQuantPredHead{} + -> noHints + TcRnIllegalTupleConstraint{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnNonTypeVarArgInConstraint{} + -> [suggestExtension LangExt.FlexibleContexts] + TcRnIllegalImplicitParam{} + -> noHints + TcRnIllegalConstraintSynonymOfKind{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnIllegalClassInst{} + -> noHints + TcRnOversaturatedVisibleKindArg{} + -> noHints + TcRnBadAssociatedType{} + -> noHints + TcRnForAllRankErr rank _ + -> case rank of + LimitedRank{} -> [suggestExtension LangExt.RankNTypes] + MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes] + MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes] + MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms] + MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints] + _ -> noHints + TcRnMonomorphicBindings bindings + -> case bindings of + [] -> noHints + (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] + TcRnOrphanInstance{} + -> [SuggestFixOrphanInstance] + TcRnFunDepConflict{} + -> noHints + TcRnDupInstanceDecls{} + -> noHints + TcRnConflictingFamInstDecls{} + -> noHints + TcRnFamInstNotInjective rea _ _ + -> case rea of + InjErrRhsBareTyVar{} -> noHints + InjErrRhsCannotBeATypeFam -> noHints + InjErrRhsOverlap -> noHints + InjErrCannotInferFromRhs _ _ suggestUndInst + | YesSuggestUndecidableInstaces <- suggestUndInst + -> [suggestExtension LangExt.UndecidableInstances] + | otherwise + -> noHints + TcRnBangOnUnliftedType{} + -> noHints + TcRnLazyBangOnUnliftedType{} + -> noHints + TcRnMultipleDefaultDeclarations{} + -> noHints + TcRnBadDefaultType{} + -> noHints + TcRnPatSynBundledWithNonDataCon{} + -> noHints + TcRnPatSynBundledWithWrongType{} + -> noHints + TcRnDupeModuleExport{} + -> noHints + TcRnExportedModNotImported{} + -> noHints + TcRnNullExportedModule{} + -> noHints + TcRnMissingExportList{} + -> noHints + TcRnExportHiddenComponents{} + -> noHints + TcRnDuplicateExport{} + -> noHints + TcRnExportedParentChildMismatch{} + -> noHints + TcRnConflictingExports{} + -> noHints + TcRnAmbiguousField{} + -> noHints + TcRnMissingFields{} + -> noHints + TcRnFieldUpdateInvalidType{} + -> noHints + TcRnNoConstructorHasAllFields{} + -> noHints + TcRnMixedSelectors{} + -> noHints + TcRnMissingStrictFields{} + -> noHints + TcRnNoPossibleParentForFields{} + -> noHints + TcRnBadOverloadedRecordUpdate{} + -> noHints + TcRnStaticFormNotClosed{} + -> noHints + TcRnUselessTypeable + -> noHints + TcRnDerivingDefaults{} + -> [useDerivingStrategies] + TcRnNonUnaryTypeclassConstraint{} + -> noHints + TcRnPartialTypeSignatures suggestParSig _ + -> case suggestParSig of + YesSuggestPartialTypeSignatures + -> let info = text "to use the inferred type" + in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] + NoSuggestPartialTypeSignatures + -> noHints + TcRnCannotDeriveInstance cls _ _ newtype_deriving rea + -> deriveInstanceErrReasonHints cls newtype_deriving rea + TcRnLazyGADTPattern + -> noHints + TcRnArrowProcGADTPattern + -> noHints + TcRnSpecialClassInst {} + -> noHints + TcRnForallIdentifier {} + -> [SuggestRenameForall] + TcRnTypeEqualityOutOfScope + -> noHints + TcRnTypeEqualityRequiresOperators + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperator {} + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperatorDecl {} + -> [suggestExtension LangExt.TypeOperators] + TcRnGADTMonoLocalBinds {} + -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] + TcRnIncorrectNameSpace nm is_th_use + | is_th_use + -> [SuggestAppropriateTHTick $ nameNameSpace nm] + | otherwise + -> noHints + TcRnNotInScope err _ _ hints + -> scopeErrorHints err ++ hints + TcRnUntickedPromotedThing thing + -> [SuggestAddTick thing] + TcRnIllegalBuiltinSyntax {} + -> noHints + TcRnWarnDefaulting {} + -> noHints + TcRnForeignImportPrimExtNotSet{} + -> [suggestExtension LangExt.GHCForeignImportPrim] + TcRnForeignImportPrimSafeAnn{} + -> noHints + TcRnForeignFunctionImportAsValue{} + -> noHints + TcRnFunPtrImportWithoutAmpersand{} + -> noHints + TcRnIllegalForeignDeclBackend{} + -> noHints + TcRnUnsupportedCallConv{} + -> noHints + TcRnIllegalForeignType _ reason + -> case reason of + TypeCannotBeMarshaled _ why + | NewtypeDataConNotInScope{} <- why -> [SuggestImportingDataCon] + | UnliftedFFITypesNeeded <- why -> [suggestExtension LangExt.UnliftedFFITypes] + _ -> noHints + TcRnInvalidCIdentifier{} + -> noHints + TcRnExpectedValueId{} + -> noHints + TcRnNotARecordSelector{} + -> noHints + TcRnRecSelectorEscapedTyVar{} + -> [SuggestPatternMatchingSyntax] + TcRnPatSynNotBidirectional{} + -> noHints + TcRnSplicePolymorphicLocalVar{} + -> noHints + TcRnIllegalDerivingItem{} + -> noHints + TcRnUnexpectedAnnotation{} + -> noHints + TcRnIllegalRecordSyntax{} + -> noHints + TcRnUnexpectedTypeSplice{} + -> noHints + TcRnInvalidVisibleKindArgument{} + -> noHints + TcRnTooManyBinders{} + -> noHints + TcRnDifferentNamesForTyVar{} + -> noHints + TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext + -> case mb_suggest_unlifted_ext of + Nothing -> noHints + Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes] + Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes] + TcRnClassKindNotConstraint{} + -> noHints + TcRnUnpromotableThing{} + -> noHints + TcRnMatchesHaveDiffNumArgs{} + -> noHints + TcRnCannotBindScopedTyVarInPatSig{} + -> noHints + TcRnCannotBindTyVarsInPatBind{} + -> noHints + TcRnTooManyTyArgsInConPattern{} + -> noHints + TcRnMultipleInlinePragmas{} + -> noHints + TcRnUnexpectedPragmas{} + -> noHints + TcRnNonOverloadedSpecialisePragma{} + -> noHints + TcRnSpecialiseNotVisible name + -> [SuggestSpecialiseVisibilityHints name] + TcRnNameByTemplateHaskellQuote{} + -> noHints + TcRnIllegalBindingOfBuiltIn{} + -> noHints + TcRnPragmaWarning{} + -> noHints + TcRnIllegalHsigDefaultMethods{} + -> noHints + TcRnBadGenericMethod{} + -> noHints + TcRnWarningMinimalDefIncomplete{} + -> noHints + TcRnDefaultMethodForPragmaLacksBinding{} + -> noHints + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> noHints + TcRnBadMethodErr{} + -> noHints + TcRnNoExplicitAssocTypeOrDefaultDeclaration{} + -> noHints + TcRnIllegalTypeData + -> [suggestExtension LangExt.TypeData] + TcRnTypeDataForbids{} + -> noHints + TcRnIllegalNewtype{} + -> noHints + TcRnTypedTHWithPolyType{} + -> noHints + TcRnSpliceThrewException{} + -> noHints + TcRnInvalidTopDecl{} + -> noHints + TcRnNonExactName{} + -> noHints + TcRnAddInvalidCorePlugin{} + -> noHints + TcRnAddDocToNonLocalDefn{} + -> noHints + TcRnFailedToLookupThInstName{} + -> noHints + TcRnCannotReifyInstance{} + -> noHints + TcRnCannotReifyOutOfScopeThing{} + -> noHints + TcRnCannotReifyThingNotInTypeEnv{} + -> noHints + TcRnNoRolesAssociatedWithThing{} + -> noHints + TcRnCannotRepresentType{} + -> noHints + TcRnRunSpliceFailure{} + -> noHints + TcRnReportCustomQuasiError{} + -> noHints + TcRnInterfaceLookupError{} + -> noHints + TcRnUnsatisfiedMinimalDef{} + -> noHints + TcRnMisplacedInstSig{} + -> [suggestExtension LangExt.InstanceSigs] + TcRnBadBootFamInstDecl{} + -> noHints + TcRnIllegalFamilyInstance{} + -> noHints + TcRnMissingClassAssoc{} + -> noHints + TcRnBadFamInstDecl{} + -> [suggestExtension LangExt.TypeFamilies] + TcRnNotOpenFamily{} + -> noHints + TcRnNoRebindableSyntaxRecordDot{} + -> noHints + TcRnNoFieldPunsRecordDot{} + -> noHints + TcRnIllegalStaticExpression{} + -> [suggestExtension LangExt.StaticPointers] + TcRnIllegalStaticFormInSplice{} + -> noHints + TcRnListComprehensionDuplicateBinding{} + -> noHints + TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{} + -> [suggestExtension LangExt.NondecreasingIndentation] + TcRnEmptyStmtsGroup{} + -> noHints + TcRnLastStmtNotExpr{} + -> noHints + TcRnUnexpectedStatementInContext _ _ mExt + | Nothing <- mExt -> noHints + | Just ext <- mExt -> [suggestExtension ext] + TcRnSectionWithoutParentheses{} + -> noHints + TcRnIllegalImplicitParameterBindings{} + -> noHints + TcRnIllegalTupleSection{} + -> [suggestExtension LangExt.TupleSections] + TcRnLoopySuperclassSolve wtd_loc wtd_pty + -> [LoopySuperclassSolveHint wtd_pty cls_or_qc] + where + cls_or_qc :: ClsInstOrQC + cls_or_qc = case ctLocOrigin wtd_loc of + ScOrigin c_or_q _ -> c_or_q + _ -> IsClsInst -- shouldn't happen + + diagnosticCode = constructorCode + +-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", +-- and so on. The `and` stands for any `conjunction`, which is passed in. +commafyWith :: SDoc -> [SDoc] -> [SDoc] +commafyWith _ [] = [] +commafyWith _ [x] = [x] +commafyWith conjunction [x, y] = [x <+> conjunction <+> y] +commafyWith conjunction xs = addConjunction $ punctuate comma xs + where addConjunction [x, y] = [x, conjunction, y] + addConjunction (x : xs) = x : addConjunction xs + addConjunction _ = panic "commafyWith expected 2 or more elements" + +deriveInstanceErrReasonHints :: Class + -> UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> [GhcHint] +deriveInstanceErrReasonHints cls newtype_deriving = \case + DerivErrNotWellKinded _ _ n_args_to_keep + | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 + -> [suggestExtension LangExt.PolyKinds] + | otherwise + -> noHints + DerivErrSafeHaskellGenericInst -> noHints + DerivErrDerivingViaWrongKind{} -> noHints + DerivErrNoEtaReduce{} -> noHints + DerivErrBootFileFound -> noHints + DerivErrDataConsNotAllInScope{} -> noHints + DerivErrGNDUsedOnData -> noHints + DerivErrNullaryClasses -> noHints + DerivErrLastArgMustBeApp -> noHints + DerivErrNoFamilyInstance{} -> noHints + DerivErrNotStockDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrHasAssociatedDatatypes{} + -> noHints + DerivErrNewtypeNonDeriveableClass + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrCannotEtaReduceEnough{} + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotAClass{} + -> noHints + DerivErrNoConstructors{} + -> let info = text "to enable deriving for empty data types" + in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] + DerivErrLangExtRequired{} + -- This is a slightly weird corner case of GHC: we are failing + -- to derive a typeclass instance because a particular 'Extension' + -- is not enabled (and so we report in the main error), but here + -- we don't want to /repeat/ to enable the extension in the hint. + -> noHints + DerivErrDunnoHowToDeriveForType{} + -> noHints + DerivErrMustBeEnumType rep_tc + -- We want to suggest GND only if this /is/ a newtype. + | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc + -> [useGND] + | otherwise + -> noHints + DerivErrMustHaveExactlyOneConstructor{} + -> noHints + DerivErrMustHaveSomeParameters{} + -> noHints + DerivErrMustNotHaveClassContext{} + -> noHints + DerivErrBadConstructor wcard _ + -> case wcard of + Nothing -> noHints + Just YesHasWildcard -> [SuggestFillInWildcardConstraint] + Just NoHasWildcard -> [SuggestAddStandaloneDerivation] + DerivErrGenerics{} + -> noHints + DerivErrEnumOrProduct{} + -> noHints + +messageWithInfoDiagnosticMessage :: UnitState + -> ErrInfo + -> Bool + -> DecoratedSDoc + -> DecoratedSDoc +messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important = + let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | show_ctxt] ++ [errInfoSupplementary]) + in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` + mkDecorated err_info' + +dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgy_msg kind tc ie + = sep [ text "The" <+> kind <+> text "item" + <+> quotes (ppr ie) + <+> text "suggests that", + quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", + text "but it has none" ] + +dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (GhcPass p) -> IE (GhcPass p) +dodgy_msg_insert tc = IEThingAll noAnn ii + where + ii :: LIEWrappedName (GhcPass p) + ii = noLocA (IEName noExtField $ noLocA tc) + +pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc +pprTypeDoesNotHaveFixedRuntimeRep ty prov = + let what = pprFixedRuntimeRepProvenance prov + in text "The" <+> what <+> text "does not have a fixed runtime representation:" + $$ format_frr_err ty + +format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation + -> SDoc +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 (typeKind ty) + +pprField :: (FieldLabelString, TcType) -> SDoc +pprField (f,ty) = ppr f <+> dcolon <+> ppr ty + +pprRecordFieldPart :: RecordFieldPart -> SDoc +pprRecordFieldPart = \case + RecordFieldConstructor{} -> text "construction" + RecordFieldPattern{} -> text "pattern" + RecordFieldUpdate -> text "update" + +pprBindings :: [Name] -> SDoc +pprBindings = pprWithCommas (quotes . ppr) + +injectivityErrorHerald :: SDoc +injectivityErrorHerald = + text "Type family equation violates the family's injectivity annotation." + +formatExportItemError :: SDoc -> String -> SDoc +formatExportItemError exportedThing reason = + hsep [ text "The export item" + , quotes exportedThing + , text reason ] + +-- | What warning flag is associated with the given missing signature? +missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag +missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden + | IsExported <- exported + , not overridden + = Opt_WarnMissingExportedSignatures + | otherwise + = Opt_WarnMissingSignatures +missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden + | IsExported <- exported + , not overridden + = Opt_WarnMissingExportedPatternSynonymSignatures + | otherwise + = Opt_WarnMissingPatternSynonymSignatures +missingSignatureWarningFlag (MissingTyConKindSig {}) _ _ + = Opt_WarnMissingKindSignatures + +useDerivingStrategies :: GhcHint +useDerivingStrategies = + useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies + +useGND :: GhcHint +useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" + in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving + +cannotMakeDerivedInstanceHerald :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- ^ If False, only prints the why. + -> SDoc + -> SDoc +cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = + if pprHerald + then sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + else why + where + strat_used = isJust mb_strat + extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + , Just strat <- mb_strat + = text "with the" <+> (derivStrategyName strat) <+> text "strategy" + | otherwise + = empty + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +derivErrDiagnosticMessage :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- If True, includes the herald \"can't make a derived..\" + -> DeriveInstanceErrReason + -> SDoc +derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case + DerivErrNotWellKinded tc cls_kind _ + -> sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 empty + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + DerivErrSafeHaskellGenericInst + -> text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + DerivErrDerivingViaWrongKind cls_kind via_ty via_kind + -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + DerivErrNoEtaReduce inst_ty + -> sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + DerivErrBootFileFound + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + DerivErrDataConsNotAllInScope tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") + 2 (text "so you cannot derive an instance for it")) + DerivErrGNDUsedOnData + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") + DerivErrNullaryClasses + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances for nullary classes") + DerivErrLastArgMustBeApp + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + ( text "The last argument of the instance must be a" + <+> text "data or newtype application") + DerivErrNoFamilyInstance tc tc_args + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) + DerivErrNotStockDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") + DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg + , case at_without_last_cls_tv of + YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc + NoAssociatedTyNotParamOverLastTyVar -> empty + , case at_last_cls_tv_in_kinds of + YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc + NoAssocTyLastVarInKind -> empty + ] + where + + adfs_msg = text "the class has associated data types" + + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + DerivErrNewtypeNonDeriveableClass + -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) + DerivErrCannotEtaReduceEnough eta_ok + -> let cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + cant_derive_err + DerivErrOnlyAnyClassDeriveable tc _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled") + DerivErrNotDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty + DerivErrNotAClass predType + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr predType) <+> text "is not a class") + DerivErrNoConstructors rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") + DerivErrLangExtRequired ext + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "You need " <> ppr ext + <+> text "to derive an instance for this class") + DerivErrDunnoHowToDeriveForType ty + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + DerivErrMustBeEnumType rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) + + DerivErrMustHaveExactlyOneConstructor rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") + DerivErrMustHaveSomeParameters rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") + DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + DerivErrBadConstructor _ reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrBadConExistential con + -> badCon con $ text "must be truly polymorphic in the last argument of the data type" + DerivErrBadConCovariant con + -> badCon con $ text "must not use the type variable in a function argument" + DerivErrBadConFunTypes con + -> badCon con $ text "must not contain function types" + DerivErrBadConWrongArg con + -> badCon con $ text "must use the type variable only as the last argument of a data type" + DerivErrBadConIsGADT con + -> badCon con $ text "is a GADT" + DerivErrBadConHasExistentials con + -> badCon con $ text "has existential type variables in its type" + DerivErrBadConHasConstraints con + -> badCon con $ text "has constraints in its type" + DerivErrBadConHasHigherRankType con + -> badCon con $ text "has a higher-rank type" + DerivErrGenerics reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrGenericsMustNotHaveDatatypeContext tc_name + -> ppr tc_name <+> text "must not have a datatype context" + DerivErrGenericsMustNotHaveExoticArgs dc + -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" + DerivErrGenericsMustBeVanillaDataCon dc + -> ppr dc <+> text "must be a vanilla data constructor" + DerivErrGenericsMustHaveSomeTypeParams rep_tc + -> text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + DerivErrGenericsMustNotHaveExistentials con + -> badCon con $ text "must not have existential arguments" + DerivErrGenericsWrongArgKind con + -> badCon con $ + text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + DerivErrEnumOrProduct this that + -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this + ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (ppr1 $$ text " or" $$ ppr2) + +{- ********************************************************************* +* * + Outputable SolverReportErrCtxt (for debugging) +* * +**********************************************************************-} + +instance Outputable SolverReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_expand_syns = es + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_expand_syns" <+> equals <+> ppr es + , text "cec_suppress" <+> equals <+> ppr sup ]) + +{- ********************************************************************* +* * + Outputting TcSolverReportMsg errors +* * +**********************************************************************-} + +-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' +-- with its enclosing 'SolverReportErrCtxt'. +pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc +pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) + = pprTcSolverReportMsg ctxt msg + +-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. +pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc +pprTcSolverReportMsg _ (BadTelescope telescope skols) = + hang (text "These kind and type variables:" <+> ppr telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + where + sorted_tvs = scopedSort skols +pprTcSolverReportMsg _ (UserTypeError ty) = + pprUserTypeErrorTy ty +pprTcSolverReportMsg ctxt (ReportHoleError hole err) = + pprHoleError ctxt hole err +pprTcSolverReportMsg ctxt + (CannotUnifyVariable + { mismatchMsg = msg + , cannotUnifyReason = reason }) + = pprMismatchMsg ctxt msg + $$ pprCannotUnifyVariableReason ctxt reason +pprTcSolverReportMsg ctxt + (Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = ambig_infos + , mismatchCoercibleInfo = coercible_info }) + = hang (pprMismatchMsg ctxt mismatch_msg) + 2 (vcat ( maybe empty (pprTyVarInfo ctxt) tv_info + : maybe empty pprCoercibleMsg coercible_info + : map pprAmbiguityInfo ambig_infos )) +pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = + vcat (map make_msg frr_origs) + where + -- Assemble the error message: pair up each origin with the corresponding type, e.g. + -- • FixedRuntimeRep origin msg 1 ... + -- a :: TYPE r1 + -- • FixedRuntimeRep origin msg 2 ... + -- b :: TYPE r2 + make_msg :: FixedRuntimeRepErrorInfo -> SDoc + make_msg (FRR_Info { frr_info_origin = + FixedRuntimeRepOrigin + { frr_type = ty + , frr_context = frr_ctxt } + , frr_info_not_concrete = + mb_not_conc }) = + -- Add bullet points if there is more than one error. + (if length frr_origs > 1 then (bullet <+>) else id) $ + vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt + , text "does not have a fixed runtime representation." ] + , type_printout ty + , case mb_not_conc of + Nothing -> empty + Just (conc_tv, not_conc) -> + unsolved_concrete_eq_explanation conc_tv not_conc ] + + -- Don't print out the type (only the kind), if the type includes + -- a confusing cast, unless the user passed -fprint-explicit-coercions. + -- + -- Example: + -- + -- In T20363, we have a representation-polymorphism error with a type + -- of the form + -- + -- ( (# #) |> co ) :: TYPE NilRep + -- + -- where NilRep is a nullary type family application which reduces to TupleRep '[]. + -- We prefer avoiding showing the cast to the user, but we also don't want to + -- print the confusing: + -- + -- (# #) :: TYPE NilRep + -- + -- So in this case we simply don't print the type, only the kind. + confusing_cast :: Type -> Bool + confusing_cast ty = + case ty of + CastTy inner_ty _ + -- A confusing cast is one that is responsible + -- for a representation-polymorphism error. + -> isConcrete (typeKind inner_ty) + _ -> False + + type_printout :: Type -> SDoc + type_printout ty = + sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> + if confusing_cast ty && not show_coercions + then vcat [ text "Its kind is:" + , nest 2 $ pprWithTYPE (typeKind ty) + , text "(Use -fprint-explicit-coercions to see the full type.)" ] + else vcat [ text "Its type is:" + , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] + + unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc + unsolved_concrete_eq_explanation tv not_conc = + text "Cannot unify" <+> quotes (ppr not_conc) + <+> text "with the type variable" <+> quotes (ppr tv) + $$ text "because it is not a concrete" <+> what <> dot + where + ki = tyVarKind tv + what :: SDoc + what + | isRuntimeRepTy ki + = quotes (text "RuntimeRep") + | isLevityTy ki + = quotes (text "Levity") + | otherwise + = text "type" +pprTcSolverReportMsg _ (UntouchableVariable tv implic) + | Implic { ic_given = given, ic_info = skol_info } <- implic + = sep [ quotes (ppr tv) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ] +pprTcSolverReportMsg _ (BlockedEquality item) = + vcat [ hang (text "Cannot use equality for substitution:") + 2 (ppr (errorItemPred item)) + , text "Doing so would be ill-kinded." ] +pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = + text "Expecting" <+> speakN (abs n) <+> + more <+> quotes (ppr thing) + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 +pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = + let givens = getUserGivens ctxt + in if null givens + then addArising (errorItemCtLoc item) $ + sep [ text "Unbound implicit parameter" <> plural preds + , nest 2 (pprParendTheta preds) ] + else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) + where + preds = map errorItemPred (item : items) +pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) = + pprAmbiguityInfo (Ambiguity True ambigs) <+> + pprArising (errorItemCtLoc item) $$ + text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) + <+> text "from being solved." +pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) + (CannotResolveInstance item unifiers candidates imp_errs suggs binds) + = + vcat + [ no_inst_msg + , nest 2 extra_note + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig $ + pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs)) + , pprRelevantBindings binds + , potential_msg ]) + , ppWhen (isNothing mb_patsyn_prov) $ + -- Don't suggest fixes for the provided context of a pattern + -- synonym; the right fix is to bind more in the pattern + show_fixes (ctxtFixes has_ambigs pred implics + ++ drv_fixes ++ naked_sc_fixes) + , ppWhen (not (null candidates)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidates))) + -- See Note [Report candidate instances] + , vcat $ map ppr imp_errs + , vcat $ map ppr suggs ] + where + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors + (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred + ambigs = ambig_kvs ++ ambig_tvs + has_ambigs = not (null ambigs) + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + lead_with_ambig = not (null ambigs) + && not (any isRuntimeUnkSkol ambigs) + && not (null unifiers) + && null useful_givens + + no_inst_msg :: SDoc + no_inst_msg + | lead_with_ambig + = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) + | otherwise + = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + potential_hdr $$ + potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) + + potential_hdr + = ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) + , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) + , Just (tc,_) <- tcSplitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + | otherwise + = empty + + drv_fixes = case orig of + DerivClauseOrigin -> [drv_fix False] + StandAloneDerivOrigin -> [drv_fix True] + DerivOriginDC _ _ standalone -> [drv_fix standalone] + DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] + _ -> [] + + drv_fix standalone_wildcard + | standalone_wildcard + = text "fill in the wildcard constraint yourself" + | otherwise + = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") + + -- naked_sc_fix: try to produce a helpful error message for + -- superclass constraints caught by the subtleties described by + -- Note [Recursive superclasses] in GHC.TyCl.Instance + naked_sc_fixes + | ScOrigin _ NakedSc <- orig -- A superclass wanted with no instance decls used yet + , any non_tyvar_preds useful_givens -- Some non-tyvar givens + = [vcat [ text "If the constraint looks soluble from a superclass of the instance context," + , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]] + | otherwise = [] + + non_tyvar_preds :: UserGiven -> Bool + non_tyvar_preds = any non_tyvar_pred . ic_given + + non_tyvar_pred :: EvVar -> Bool + -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars + non_tyvar_pred given = case getClassPredTys_maybe (idType given) of + Just (_, tys) -> not (all isTyVarTy tys) + Nothing -> False + +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = + vcat + [ addArising ct_loc $ + (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + , potentialInstancesErrMsg + (PotentialInstances { matches = NE.toList matches, unifiers }) + , ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ text "There exists a (perhaps superclass) match:" + , nest 2 (vcat (pp_givens useful_givens))] + + , ppWhen (null $ NE.tail matches) $ + parens (vcat [ ppUnless (null tyCoVars) $ + text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr tyCoVars) + , ppUnless (null famTyCons) $ + if (null tyCoVars) + then + text "The choice depends on the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + else + text "and the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + , ppWhen (null (matching_givens)) $ + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] + ])] + where + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + matching_givens = mapMaybe matchable useful_givens + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False +pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) = + vcat [ addArising ct_loc (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance match)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped]) + ] + ] + where + ct_loc = errorItemCtLoc item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + +pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc +pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) = + vcat [ (if isSkolemTyVar tv1 + then text "Cannot equate type variable" + else text "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) + , maybe empty (pprTyVarInfo ctxt) mb_tv_info ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) = + let + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + in + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr (ic_info implic) + , nest 2 $ text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ] ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason ctxt + (OccursCheck + { occursCheckInterestingTyVars = interesting_tvs + , occursCheckAmbiguityInfos = ambig_infos }) + = ppr_interesting_tyVars interesting_tvs + $$ vcat (map pprAmbiguityInfo ambig_infos) + where + ppr_interesting_tyVars [] = empty + ppr_interesting_tyVars (tv:tvs) = + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + (tv:tvs)) + tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) +pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info) + = pprTyVarInfo ctxt tv_info +pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg) + = pprTyVarInfo ctxt tv_info + $$ maybe empty pprCoercibleMsg mb_coercible_msg + +pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc +pprMismatchMsg ctxt + (BasicMismatch { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 -- Expected + , mismatch_ty2 = ty2 -- Actual + , mismatch_whenMatching = mb_match_txt + , mismatch_mb_same_occ = 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) || + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || + (isLiftedLevity ty1 && isUnliftedLevity ty2) || + (isLiftedLevity ty2 && isUnliftedLevity ty1) + = text "Couldn't match a lifted type with an unlifted type" + + | isAtomicTy ty1 || isAtomicTy ty2 + = -- Print with quotes + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) ] + + | otherwise + = -- Print with vertical layout + vcat [ text herald1 <> colon <+> ppr ty1 + , nest padding $ + text herald2 <> colon <+> ppr ty2 ] + + 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 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) + + conc :: [String] -> String + conc = foldr1 add_space + + add_space :: String -> String -> String + add_space s1 s2 | null s1 = s2 + | null s2 = s1 + | otherwise = s1 ++ (' ' : s2) +pprMismatchMsg _ + (KindMismatch { kmismatch_what = thing + , kmismatch_expected = exp + , kmismatch_actual = act }) + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + 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) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) + +pprMismatchMsg ctxt + (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_item = item + , 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 + $$ maybe empty pprSameOccInfo mb_same_occ + where + 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) ] + + 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 + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- mb_thing + -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + 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 $$ + case supplementary of + Left infos + -> vcat (map (pprExpectedActualInfo ctxt) infos) + Right other_msg + -> pprMismatchMsg ctxt other_msg + where + main_msg + | null useful_givens + = addArising ct_loc (no_instance_msg <+> missing) + | otherwise + = vcat (addArising ct_loc (no_deduce_msg <+> missing) + : pp_givens useful_givens) + + supplementary = case mb_extra of + Nothing + -> Left [] + Just (CND_Extra level ty1 ty2) + -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + wanteds = map errorItemPred (item:others) + + no_instance_msg = + case wanteds of + [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted + -- Don't say "no instance" for a constraint such as "c" for a type variable c. + , isClassTyCon tc -> text "No instance for" + _ -> text "Could not solve:" + + no_deduce_msg = + case wanteds of + [_wanted] -> text "Could not deduce" + _ -> text "Could not deduce:" + + missing = + case wanteds of + [wanted] -> quotes (ppr wanted) + _ -> pprTheta wanteds + + + +{- ********************************************************************* +* * + Displaying potential instances +* * +**********************************************************************-} + +-- | Directly display the given matching and unifying instances, +-- with a header for each: `Matching instances`/`Potentially matching instances`. +pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc +pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = + vcat + [ ppWhen (not $ null matches) $ + text "Matching instance" <> plural matches <> colon $$ + nest 2 (vcat (map ppr_inst matches)) + , ppWhen (not $ null unifiers) $ + (text "Potentially matching instance" <> plural unifiers <> colon) $$ + nest 2 (vcat (map ppr_inst unifiers)) + ] + +-- | Display a summary of available instances, omitting those involving +-- out-of-scope types, in order to explain why we couldn't solve a particular +-- constraint, e.g. due to instance overlap or out-of-scope types. +-- +-- To directly display a collection of matching/unifying instances, +-- use 'pprPotentialInstances'. +potentialInstancesErrMsg :: PotentialInstances -> SDoc +-- See Note [Displaying potential instances] +potentialInstancesErrMsg potentials = + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + potentials_msg_with_options potentials print_insts sty + +-- | Display a summary of available instances, omitting out-of-scope ones. +-- +-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing +-- options. +potentials_msg_with_options :: PotentialInstances + -> Bool -- ^ Whether to print /all/ potential instances + -> PprStyle + -> SDoc +potentials_msg_with_options + (PotentialInstances { matches, unifiers }) + show_all_potentials sty + | null matches && null unifiers + = empty + + | null show_these_matches && null show_these_unifiers + = vcat [ not_in_scope_msg empty + , flag_hint ] + + | otherwise + = vcat [ pprPotentialInstances + pprInstance -- print instance + location info + (PotentialInstances + { matches = show_these_matches + , unifiers = show_these_unifiers }) + , overlapping_but_not_more_specific_msg sorted_matches + , nest 2 $ vcat + [ ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , ppWhen (not_in_scopes > 0) $ + not_in_scope_msg (text "...plus") + , flag_hint ] ] + where + n_show_matches, n_show_unifiers :: Int + n_show_matches = 3 + n_show_unifiers = 2 + + (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches + (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers + sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches + sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers + (show_these_matches, show_these_unifiers) + | show_all_potentials = (sorted_matches, sorted_unifiers) + | otherwise = (take n_show_matches sorted_matches + ,take n_show_unifiers sorted_unifiers) + n_in_scope_hidden + = length sorted_matches + length sorted_unifiers + - length show_these_matches - length show_these_unifiers + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | pretendNameIsInScope name + = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scopes :: Int + not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers + + not_in_scope_msg herald = + hang (herald <+> speakNOf not_in_scopes (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_all_potentials $ + pprPotentialInstances + pprInstanceHdr -- only print the header, not the instance location info + (PotentialInstances + { matches = not_in_scope_matches + , unifiers = not_in_scope_unifiers + })) + + flag_hint = ppUnless (show_all_potentials + || (equalLength show_these_matches matches + && equalLength show_these_unifiers unifiers)) $ + text "(use -fprint-potential-instances to see them all)" + +-- | Compute a message informing the user of any instances that are overlapped +-- but were not discarded because the instance overlapping them wasn't +-- strictly more specific. +overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc +overlapping_but_not_more_specific_msg insts + -- Only print one example of "overlapping but not strictly more specific", + -- to avoid information overload. + | overlap : _ <- overlapping_but_not_more_specific + = overlap_header $$ ppr_overlapping overlap + | otherwise + = empty + where + overlap_header :: SDoc + overlap_header + | [_] <- overlapping_but_not_more_specific + = text "An overlapping instance can only be chosen when it is strictly more specific." + | otherwise + = text "Overlapping instances can only be chosen when they are strictly more specific." + overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] + overlapping_but_not_more_specific + = nubOrdBy (comparing (is_dfun . fst)) + [ (overlapper, overlappee) + | these <- groupBy ((==) `on` is_cls_nm) insts + -- Take all pairs of distinct instances... + , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` + , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` + -- ... such that one instance in the pair overlaps the other... + , let mb_overlapping + | hasOverlappingFlag (overlapMode $ is_flag one) + || hasOverlappableFlag (overlapMode $ is_flag other) + = [(one, other)] + | hasOverlappingFlag (overlapMode $ is_flag other) + || hasOverlappableFlag (overlapMode $ is_flag one) + = [(other, one)] + | otherwise + = [] + , (overlapper, overlappee) <- mb_overlapping + -- ... but the overlapper is not more specific than the overlappee. + , not (overlapper `more_specific_than` overlappee) + ] + more_specific_than :: ClsInst -> ClsInst -> Bool + is1 `more_specific_than` is2 + = isJust (tcMatchTys (is_tys is1) (is_tys is2)) + ppr_overlapping :: (ClsInst, ClsInst) -> SDoc + ppr_overlapping (overlapper, overlappee) + = text "The first instance that follows overlaps the second, but is not more specific than it:" + $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus N others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- ********************************************************************* +* * + Outputting additional solver report information +* * +**********************************************************************-} + +-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. +pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc +pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = + vcat + [ text "Expected:" <+> ppr exp + , text " Actual:" <+> ppr act ] +pprExpectedActualInfo _ + (ExpectedActualAfterTySynExpansion + { ea_expanded_expected = exp + , ea_expanded_actual = act } ) + = vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +pprCoercibleMsg :: CoercibleMsg -> SDoc +pprCoercibleMsg (UnknownRoles ty) = + hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr ty) <+> text "have;") + 2 (text "we must assume that the role is nominal") +pprCoercibleMsg (TyConIsAbstract tc) = + hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] +pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = + hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + +pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc +pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = + sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + if printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + then vcat [ hang (text "When matching" <+> sub_whats) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (typeKind cty2) ]) + , supplementary ] + else text "When matching the kind of" <+> quotes (ppr cty1) + where + sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel + sub_whats = text (levelString sub_t_or_k) <> char 's' + supplementary = + case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of + Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos + Right msg -> pprMismatchMsg ctxt msg + +pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc +pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2 }) = + mk_msg tv1 $$ case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 } + where + mk_msg tv = case tcTyVarDetails tv of + SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty + +pprAmbiguityInfo :: AmbiguityInfo -> SDoc +pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg + where + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" +pprAmbiguityInfo (NonInjectiveTyFam tc) = + text "NB:" <+> quotes (ppr tc) + <+> text "is a non-injective type family" + +pprSameOccInfo :: SameOccInfo -> SDoc +pprSameOccInfo (SameOcc same_pkg n1 n2) = + text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnit) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- ********************************************************************* +* * + Outputting HoleError messages +* * +**********************************************************************-} + +pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc +pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs) + = out_of_scope_msg $$ vcat (map ppr imp_errs) + where + herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr rdr) + | otherwise = hang herald 2 (pp_rdr_with_type rdr hole_ty) + boring_type = isTyVarTy hole_ty +pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = + vcat [ hole_msg + , tyvars_msg + , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] + + where + + hole_msg = case sort of + ExprHole {} -> + hang (text "Found hole:") + 2 (pp_rdr_with_type hole_occ hole_ty) + TypeHole -> + hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + ConstraintHole -> + hang (text "Found extra-constraints wildcard standing for") + 2 (quotes $ pprType hole_ty) -- always kind constraint + + hole_kind = typeKind hole_ty + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isCoVarType hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars = tyCoVarsOfTypeList hole_ty + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt hole_skol_info) + -- Coercion variables can be free in the + -- hole, via kind casts + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr hole_occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + type_hole_hint + | ErrorWithoutFlag <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +pp_rdr_with_type :: RdrName -> Type -> SDoc +pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + +{- ********************************************************************* +* * + Outputting ScopeError messages +* * +**********************************************************************-} + +pprScopeError :: RdrName -> NotInScopeError -> SDoc +pprScopeError rdr_name scope_err = + case scope_err of + NotInScope {} -> + hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + NoExactName name -> + text "The Name" <+> quotes (ppr name) <+> text "is not in scope." + SameName gres -> + assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) + $ hang (text "Same Name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names)) + where + sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + MissingBinding thing _ -> + sep [ text "The" <+> thing + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding" ] + NoTopLevelBinding -> + hang (text "No top-level binding for") + 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") + UnknownSubordinate doc -> + quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +scopeErrorHints :: NotInScopeError -> [GhcHint] +scopeErrorHints scope_err = + case scope_err of + NotInScope -> noHints + NoExactName {} -> [SuggestDumpSlices] + SameName {} -> [SuggestDumpSlices] + MissingBinding _ hints -> hints + NoTopLevelBinding -> noHints + UnknownSubordinate {} -> noHints + +{- ********************************************************************* +* * + Outputting ImportError messages +* * +**********************************************************************-} + +instance Outputable ImportError where + ppr (MissingModule mod_name) = + hsep + [ text "NB: no module named" + , quotes (ppr mod_name) + , text "is imported." + ] + ppr (ModulesDoNotExport mods occ_name) + | mod NE.:| [] <- mods + = hsep + [ text "NB: the module" + , quotes (ppr mod) + , text "does not export" + , quotes (ppr occ_name) <> dot ] + | otherwise + = hsep + [ text "NB: neither" + , quotedListWithNor (map ppr $ NE.toList mods) + , text "export" + , quotes (ppr occ_name) <> dot ] + +{- ********************************************************************* +* * + Suggested fixes for implication constraints +* * +**********************************************************************-} + +-- TODO: these functions should use GhcHint instead. + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +pp_givens :: [Implication] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs + where + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) + = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) + -- See Note [Suppress redundant givens during error reporting] + -- for why we use mkMinimalBySCs above. + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ]) + +{- ********************************************************************* +* * + CtOrigin information +* * +**********************************************************************-} + +levelString :: TypeOrKind -> String +levelString TypeLevel = "type" +levelString KindLevel = "kind" + +pprArising :: CtLoc -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, givens +pprArising ct_loc + | in_generated_code = empty -- See Note ["Arising from" messages in generated code] + | suppress_origin = empty + | otherwise = pprCtOrigin orig + where + orig = ctLocOrigin ct_loc + in_generated_code = lclEnvInGeneratedCode (ctLocEnv ct_loc) + suppress_origin + | isGivenOrigin orig = True + | otherwise = case orig of + TypeEqOrigin {} -> True -- We've done special processing + KindEqOrigin {} -> True -- for TypeEq, KindEq, givens + AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context + -- is sufficient; more would be repetitive + _ -> False + +-- Add the "arising from..." part to a message +addArising :: CtLoc -> SDoc -> SDoc +addArising ct_loc msg = hang msg 2 (pprArising ct_loc) + +pprWithArising :: [Ct] -> SDoc +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = addArising loc (pprTheta [ctPred ct]) + | otherwise + = vcat (map ppr_one (ct:cts)) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +{- Note ["Arising from" messages in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider code generated when we desugar code before typechecking; +see Note [Rebindable syntax and HsExpansion]. + +In this code, constraints may be generated, but we don't want to +say "arising from a call of foo" if 'foo' doesn't appear in the +users code. We leave the actual CtOrigin untouched (partly because +it is generated in many, many places), but suppress the "Arising from" +message for constraints that originate in generated code. +-} + + +{- ********************************************************************* +* * + SkolemInfo +* * +**********************************************************************-} + + +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) + +---------------- +tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon +tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfoAnon _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + 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 + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc +pprSkols ctxt zonked_ty_vars + = + let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars + in vcat (map pp_one tidy_ty_vars) + where + + no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + + + pp_one (UnkSkol cs, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "(rigid, skolem)") + , nest 2 (text "of unknown origin") + , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) + , no_msg + , prettyCallStackDoc cs + ] + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +skolsSpan :: [TcTyVar] -> SrcSpan +skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) + +{- ********************************************************************* +* * + Utilities for expected/actual messages +* * +**********************************************************************-} + +mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind + -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg +mk_supplementary_ea_msg ctxt level ty1 ty2 orig + | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig + , not (ea_looks_same ty1 ty2 exp act) + = mk_ea_msg ctxt Nothing level orig + | otherwise + = Left [] + +ea_looks_same :: Type -> Type -> Type -> Type -> Bool +-- True if the faulting types (ty1, ty2) look the same as +-- the expected/actual types (exp, act). +-- If so, we don't want to redundantly report the latter +ea_looks_same ty1 ty2 exp act + = (act `looks_same` ty1 && exp `looks_same` ty2) || + (exp `looks_same` ty1 && act `looks_same` ty2) + where + looks_same t1 t2 = t1 `pickyEqType` t2 + || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind + -- pickyEqType is sensitive to synonyms, so only replies True + -- when the types really look the same. However, + -- (TYPE 'LiftedRep) and Type both print the same way. + +mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind + -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg +-- Constructs a "Couldn't match" message +-- The (Maybe ErrorItem) says whether this is the main top-level message (Just) +-- or a supplementary message (Nothing) +mk_ea_msg ctxt at_top level + (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) + | Just thing <- mb_thing + , KindLevel <- level + = Right $ KindMismatch { kmismatch_what = thing + , kmismatch_expected = exp + , kmismatch_actual = act } + | Just item <- at_top + , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing + mismatch = mkBasicMismatchMsg ea item exp act + = Right mismatch + | otherwise + = Left $ + if expanded_syns + then [ea,ea_expanded] + else [ea] + + where + ea = ExpectedActual { ea_expected = exp, ea_actual = act } + ea_expanded = + ExpectedActualAfterTySynExpansion + { ea_expanded_expected = expTy1 + , ea_expanded_actual = expTy2 } + + expanded_syns = cec_expand_syns ctxt + && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) + (expTy1, expTy2) = expandSynonymsToMatch exp act +mk_ea_msg _ _ _ _ = Left [] + +{- Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = + unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) + in (TyConApp tc1 tys1', TyConApp tc2 tys2') + + go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } + , ty2 { ft_arg = t2_1', ft_res = t2_2' }) + + go (ForAllTy b1 t1) (ForAllTy b2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. Short version: We probably need RnEnv2 to really get this right. + let (t1', t2') = go t1 t2 + in (ForAllTy b1 t1', ForAllTy b2 t2') + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go t1 t2 = + -- See Note [Expanding type synonyms to make types similar] for how this + -- works + let + t1_exp_tys = t1 : tyExpansions t1 + t2_exp_tys = t2 : tyExpansions t2 + t1_exps = length t1_exp_tys + t2_exps = length t2_exp_tys + dif = abs (t1_exps - t2_exps) + in + followExpansions $ + zipEqual "expandSynonymsToMatch.go" + (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) + (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) + + -- Expand the top layer type synonyms repeatedly, collect expansions in a + -- list. The list does not include the original type. + -- + -- Example, if you have: + -- + -- type T10 = T9 + -- type T9 = T8 + -- ... + -- type T0 = Int + -- + -- `tyExpansions T10` returns [T9, T8, T7, ... Int] + -- + -- This only expands the top layer, so if you have: + -- + -- type M a = Maybe a + -- + -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) + tyExpansions :: Type -> [Type] + 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). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names + +pprConversionFailReason :: ConversionFailReason -> SDoc +pprConversionFailReason = \case + IllegalOccName ctxt_ns occ -> + text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) + SumAltArityExceeded alt arity -> + text "Sum alternative" <+> int alt + <+> text "exceeds its arity," <+> int arity + IllegalSumAlt alt -> + vcat [ text "Illegal sum alternative:" <+> int alt + , nest 2 $ text "Sum alternatives must start from 1" ] + IllegalSumArity arity -> + vcat [ text "Illegal sum arity:" <+> int arity + , nest 2 $ text "Sums must have an arity of at least 2" ] + MalformedType typeOrKind ty -> + text "Malformed " <> text ty_str <+> text (show ty) + where ty_str = case typeOrKind of + TypeLevel -> "type" + KindLevel -> "kind" + IllegalLastStatement do_or_lc stmt -> + vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon + , nest 2 $ ppr stmt + , text "(It should be an expression.)" ] + KindSigsOnlyAllowedOnGADTs -> + text "Kind signatures are only allowed on GADTs" + IllegalDeclaration declDescr bad_decls -> + sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon + , nest 2 bads ] + where + (what, bads) = case bad_decls of + IllegalDecls (NE.toList -> decls) -> + (text "declaration" <> plural decls, vcat $ map ppr decls) + IllegalFamDecls (NE.toList -> decls) -> + ( text "family declaration" <> plural decls, vcat $ map ppr decls) + descrDoc = text $ case declDescr of + InstanceDecl -> "an instance declaration" + WhereClause -> "a where clause" + LetBinding -> "a let expression" + LetExpression -> "a let expression" + ClssDecl -> "a class declaration" + CannotMixGADTConsWith98Cons -> + text "Cannot mix GADT constructors with Haskell 98" + <+> text "constructors" + EmptyStmtListInDoBlock -> + text "Empty stmt list in do-block" + NonVarInInfixExpr -> + text "Non-variable expression is not allowed in an infix expression" + MultiWayIfWithoutAlts -> + text "Multi-way if-expression with no alternatives" + CasesExprWithoutAlts -> + text "\\cases expression with no alternatives" + ImplicitParamsWithOtherBinds -> + text "Implicit parameters mixed with other bindings" + InvalidCCallImpent from -> + text (show from) <+> text "is not a valid ccall impent" + RecGadtNoCons -> + text "RecGadtC must have at least one constructor name" + GadtNoCons -> + text "GadtC must have at least one constructor name" + InvalidTypeInstanceHeader tys -> + text "Invalid type instance header:" + <+> text (show tys) + InvalidTyFamInstLHS lhs -> + text "Invalid type family instance LHS:" + <+> text (show lhs) + InvalidImplicitParamBinding -> + text "Implicit parameter binding only allowed in let or where" + DefaultDataInstDecl adts -> + (text "Default data instance declarations" + <+> text "are not allowed:") + $$ ppr adts + FunBindLacksEquations nm -> + text "Function binding for" + <+> quotes (text (TH.pprint nm)) + <+> text "has no equations" diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,2768 +1,4025 @@ -{-# LANGUAGE GADTs #-} - -module GHC.Tc.Errors.Types ( - -- * Main types - TcRnMessage(..) - , TcRnMessageDetailed(..) - , ErrInfo(..) - , FixedRuntimeRepProvenance(..) - , pprFixedRuntimeRepProvenance - , ShadowedNameProvenance(..) - , RecordFieldPart(..) - , InjectivityErrReason(..) - , HasKinds(..) - , hasKinds - , SuggestUndecidableInstances(..) - , suggestUndecidableInstances - , NotClosedReason(..) - , SuggestPartialTypeSignatures(..) - , suggestPartialTypeSignatures - , DeriveInstanceErrReason(..) - , UsingGeneralizedNewtypeDeriving(..) - , usingGeneralizedNewtypeDeriving - , DeriveAnyClassEnabled(..) - , deriveAnyClassEnabled - , DeriveInstanceBadConstructor(..) - , HasWildcard(..) - , hasWildcard - , BadAnonWildcardContext(..) - , SoleExtraConstraintWildcardAllowed(..) - , DeriveGenericsErrReason(..) - , HasAssociatedDataFamInsts(..) - , hasAssociatedDataFamInsts - , AssociatedTyLastVarInKind(..) - , associatedTyLastVarInKind - , AssociatedTyNotParamOverLastTyVar(..) - , associatedTyNotParamOverLastTyVar - , MissingSignature(..) - , Exported(..) - , HsDocContext(..) - , FixedRuntimeRepErrorInfo(..) - - , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc - - , SolverReport(..), SolverReportSupplementary(..) - , SolverReportWithCtxt(..) - , SolverReportErrCtxt(..) - , getUserGivens, discardProvCtxtGivens - , TcSolverReportMsg(..), TcSolverReportInfo(..) - , CND_Extra(..) - , mkTcReportWithInfo - , FitsMbSuppressed(..) - , ValidHoleFits(..), noValidHoleFits - , HoleFitDispConfig(..) - , RelevantBindings(..), pprRelevantBindings - , NotInScopeError(..), mkTcRnNotInScope - , ImportError(..) - , HoleError(..) - , CoercibleMsg(..) - , PotentialInstances(..) - , UnsupportedCallConvention(..) - , ExpectedBackends(..) - , ArgOrResult(..) - ) where - -import GHC.Prelude - -import GHC.Hs -import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) -import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit) -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence (EvBindsVar) -import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) - , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing - , FixedRuntimeRepOrigin(..) ) -import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType) -import GHC.Types.Error -import GHC.Types.Hint (UntickedPromotedThing(..)) -import GHC.Types.FieldLabel (FieldLabelString) -import GHC.Types.ForeignCall (CLabelString) -import GHC.Types.Name (Name, OccName, getSrcLoc) -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import GHC.Types.TyThing (TyThing) -import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar) -import GHC.Types.Var.Env (TidyEnv) -import GHC.Types.Var.Set (TyVarSet, VarSet) -import GHC.Unit.Types (Module) -import GHC.Utils.Outputable -import GHC.Core.Class (Class) -import GHC.Core.Coercion.Axiom (CoAxBranch) -import GHC.Core.ConLike (ConLike) -import GHC.Core.DataCon (DataCon) -import GHC.Core.FamInstEnv (FamInst) -import GHC.Core.InstEnv (ClsInst) -import GHC.Core.PatSyn (PatSyn) -import GHC.Core.Predicate (EqRel, predTypeEqRel) -import GHC.Core.TyCon (TyCon, TyConFlavour) -import GHC.Core.Type (Kind, Type, ThetaType, PredType) -import GHC.Driver.Backend (Backend) -import GHC.Unit.State (UnitState) -import GHC.Unit.Module.Name (ModuleName) -import GHC.Types.Basic -import GHC.Utils.Misc (filterOut) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.FastString (FastString) - -import qualified Data.List.NonEmpty as NE -import Data.Typeable hiding (TyCon) -import qualified Data.Semigroup as Semigroup - -{- -Note [Migrating TcM Messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As part of #18516, we are slowly migrating the diagnostic messages emitted -and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted -some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions -that accepted 3 SDocs an input: one for the important part of the message, -one for the context and one for any supplementary information. Consider the following: - - • Couldn't match expected type ‘Int’ with actual type ‘Char’ - • In the expression: x4 - In a stmt of a 'do' block: return (x2, x4) - In the expression: - -Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" -as the important part, "In the expression" as the context and "In a stmt..In the expression" -as the supplementary, with the context and supplementary usually smashed together so that -the final message would be composed only by two SDoc (which would then be bulletted like in -the example). - -In order for us to smooth out the migration to the new diagnostic infrastructure, we -introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose -of bridging the two worlds together without breaking the external API or the existing -format of messages reported by GHC. - -Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden -diagnostic API inside Tc.Utils.Monad, enabling further refactorings. - -In the future, once the conversion will be complete and we will successfully eradicate -any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and -existence of these two types, which for now remain a "necessary evil". - --} - --- The majority of TcRn messages come with extra context about the error, --- and this newtype captures it. See Note [Migrating TcM Messages]. -data ErrInfo = ErrInfo { - errInfoContext :: !SDoc - -- ^ Extra context associated to the error. - , errInfoSupplementary :: !SDoc - -- ^ Extra supplementary info associated to the error. - } - - --- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside --- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing --- any extra info needed to correctly pretty-print this diagnostic later on. -data TcRnMessageDetailed - = TcRnMessageDetailed !ErrInfo - -- ^ Extra info associated with the message - !TcRnMessage - --- | An error which might arise during typechecking/renaming. -data TcRnMessage where - {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins - to provide custom diagnostic messages originated during typechecking/renaming. - -} - TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage - - {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed - to be provided in order to qualify a diagnostic and where it was originated (and why). - It carries an extra 'UnitState' which can be used to pretty-print some names - and it wraps a 'TcRnMessageDetailed', which includes any extra context associated - with this diagnostic. - -} - TcRnMessageWithInfo :: !UnitState - -- ^ The 'UnitState' will allow us to pretty-print - -- some diagnostics with more detail. - -> !TcRnMessageDetailed - -> TcRnMessage - - {-| TcRnSolverReport is the constructor used to report unsolved constraints - after constraint solving, as well as other errors such as hole fit errors. - - See the documentation of the 'TcSolverReportMsg' datatype for an overview - of the different errors. - -} - TcRnSolverReport :: [SolverReportWithCtxt] - -> DiagnosticReason - -> [GhcHint] - -> TcRnMessage - -- TODO: split up TcRnSolverReport into several components, - -- so that we can compute the reason and hints, as opposed - -- to having to pass them here. - - {-| TcRnRedundantConstraints is a warning that is emitted when a binding - has a user-written type signature which contains superfluous constraints. - - Example: - - f :: (Eq a, Ord a) => a -> a -> a - f x y = (x < y) || x == y - -- `Eq a` is superfluous: the `Ord a` constraint suffices. - - Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. - -} - TcRnRedundantConstraints :: [Id] - -> (SkolemInfoAnon, Bool) - -- ^ The contextual skolem info. - -- The boolean controls whether we - -- want to show it in the user message. - -- (Nice to keep track of the info in either case, - -- for other users of the GHC API.) - -> TcRnMessage - - {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern - match is inaccessible, because the constraint solver has detected a contradiction. - - Example: - - data B a where { MkTrue :: B True; MkFalse :: B False } - - foo :: B False -> Bool - foo MkFalse = False - foo MkTrue = True -- Inaccessible: requires True ~ False - - Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. - -} - TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. - -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s). - -> TcRnMessage - - {-| A type which was expected to have a fixed runtime representation - does not have a fixed runtime representation. - - Example: - - data D (a :: TYPE r) = MkD a - - Test cases: T11724, T18534, - RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype, - RepPolyPatSynRes, T20423 - -} - TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type - -> !FixedRuntimeRepProvenance - -> !ErrInfo -- Extra info accumulated in the TcM monad - -> TcRnMessage - - {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when - a Template Haskell quote implicitly uses 'lift'. - - Example: - warning1 :: Lift t => t -> Q Exp - warning1 x = [| x |] - - Test cases: th/T17804 - -} - TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage - {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) - that occurs if a pattern binding binds no variables at all, unless it is a - lone wild-card pattern, or a banged pattern. - - Example: - Just _ = rhs3 -- Warning: unused pattern binding - (_, _) = rhs4 -- Warning: unused pattern binding - _ = rhs3 -- No warning: lone wild-card pattern - !() = rhs4 -- No warning: banged pattern; behaves like seq - - Test cases: rename/{T13646,T17c,T17e,T7085} - -} - TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage - {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when - a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported - abstractly, i.e. 'T'. - - Test cases: rename/should_compile/T7167 - -} - TcRnDodgyImports :: RdrName -> TcRnMessage - {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype - 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a - type/data family. - - Example: - module Foo ( - T(..) -- Warning: T is a type synonym - , A(..) -- Warning: A is a type family - , C(..) -- Warning: C is a data family - ) where - - type T = Int - type family A :: * -> * - data family C :: * -> * - - Test cases: warnings/should_compile/DodgyExports01 - -} - TcRnDodgyExports :: Name -> TcRnMessage - {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when - an import declaration does not explicitly list all the names brought into scope. - - Test cases: rename/should_compile/T4489 - -} - TcRnMissingImportList :: IE GhcPs -> TcRnMessage - {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled - with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the - reason the module was inferred to be unsafe. This warning is not raised if the - -fplugin-trustworthy flag is passed. - - Test cases: plugins/T19926 - -} - TcRnUnsafeDueToPlugin :: TcRnMessage - {-| TcRnModMissingRealSrcSpan is an error that occurrs when compiling a module that lacks - an associated 'RealSrcSpan'. - - Test cases: None - -} - TcRnModMissingRealSrcSpan :: Module -> TcRnMessage - {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs - when an identifier required by a signature is not exported by the module - or signature that is being used as a substitution for that signature. - - Example(s): None - - Test cases: backpack/should_fail/bkpfail36 - -} - TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage - {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that - occurs when an identifier which is necessary for implementing a module - signature is not exported from that signature. - - Example(s): None - - Test cases: backpack/should_fail/bkpfail30 - backpack/should_fail/bkpfail31 - backpack/should_fail/bkpfail34 - -} - TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage - - {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever - an inner-scope value has the same name as an outer-scope value, i.e. the inner - value shadows the outer one. This can catch typographical errors that turn into - hard-to-find bugs. The warning is suppressed for names beginning with an underscore. - - Examples(s): - f = ... let f = id in ... f ... -- NOT OK, 'f' is shadowed - f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore - - Test cases: typecheck/should_compile/T10971a - rename/should_compile/rn039 - rename/should_compile/rn064 - rename/should_compile/T1972 - rename/should_fail/T2723 - rename/should_compile/T3262 - driver/werror - -} - TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage - - {-| TcRnDuplicateWarningDecls is an error that occurs whenever - a warning is declared twice. - - Examples(s): - None. - - Test cases: - None. - -} - TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage - - {-| TcRnDuplicateWarningDecls is an error that occurs whenever - the constraint solver in the simplifier hits the iterations' limit. - - Examples(s): - None. - - Test cases: - None. - -} - TcRnSimplifierTooManyIterations :: Cts - -> !IntWithInf - -- ^ The limit. - -> WantedConstraints - -> TcRnMessage - - {-| TcRnIllegalPatSynDecl is an error that occurs whenever - there is an illegal pattern synonym declaration. - - Examples(s): - - varWithLocalPatSyn x = case x of - P -> () - where - pattern P = () -- not valid, it can't be local, it must be defined at top-level. - - Test cases: patsyn/should_fail/local - -} - TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage - - {-| TcRnLinearPatSyn is an error that occurs whenever a pattern - synonym signature uses a field that is not unrestricted. - - Example(s): None - - Test cases: linear/should_fail/LinearPatSyn2 - -} - TcRnLinearPatSyn :: !Type -> TcRnMessage - - {-| TcRnEmptyRecordUpdate is an error that occurs whenever - a record is updated without specifying any field. - - Examples(s): - - $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions - - Test cases: th/T12788 - -} - TcRnEmptyRecordUpdate :: TcRnMessage - - {-| TcRnIllegalFieldPunning is an error that occurs whenever - field punning is used without the 'NamedFieldPuns' extension enabled. - - Examples(s): - - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo Foo{a} = a -- Not ok, punning used without extension. - - Test cases: parser/should_fail/RecordDotSyntaxFail12 - -} - TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage - - {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever - wildcards (..) are used in a record without the relevant - extension being enabled. - - Examples(s): - - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo Foo{..} = a -- Not ok, wildcards used without extension. - - Test cases: parser/should_fail/RecordWildCardsFail - -} - TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage - - {-| TcRnIllegalWildcardInType is an error that occurs - when a wildcard appears in a type in a location in which - wildcards aren't allowed. - - Examples: - - Type synonyms: - - type T = _ - - Class declarations and instances: - - class C _ - instance C _ - - Standalone kind signatures: - - type D :: _ - data D - - Test cases: - ExtraConstraintsWildcardInTypeSplice2 - ExtraConstraintsWildcardInTypeSpliceUsed - ExtraConstraintsWildcardNotLast - ExtraConstraintsWildcardTwice - NestedExtraConstraintsWildcard - NestedNamedExtraConstraintsWildcard - PartialClassMethodSignature - PartialClassMethodSignature2 - T12039 - T13324_fail1 - UnnamedConstraintWildcard1 - UnnamedConstraintWildcard2 - WildcardInADT1 - WildcardInADT2 - WildcardInADT3 - WildcardInADTContext1 - WildcardInDefault - WildcardInDefaultSignature - WildcardInDeriving - WildcardInForeignExport - WildcardInForeignImport - WildcardInGADT1 - WildcardInGADT2 - WildcardInInstanceHead - WildcardInInstanceSig - WildcardInNewtype - WildcardInPatSynSig - WildcardInStandaloneDeriving - WildcardInTypeFamilyInstanceRHS - WildcardInTypeSynonymRHS - saks_fail003 - T15433a - -} - - TcRnIllegalWildcardInType - :: Maybe Name - -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard - -> !BadAnonWildcardContext - -> !(Maybe HsDocContext) - -> TcRnMessage - - - {-| TcRnDuplicateFieldName is an error that occurs whenever - there are duplicate field names in a record. - - Examples(s): None. - - Test cases: None. - -} - TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage - - {-| TcRnIllegalViewPattern is an error that occurs whenever - the ViewPatterns syntax is used but the ViewPatterns language extension - is not enabled. - - Examples(s): - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled. - - Test cases: parser/should_fail/ViewPatternsFail - -} - TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage - - {-| TcRnCharLiteralOutOfRange is an error that occurs whenever - a character is out of range. - - Examples(s): None - - Test cases: None - -} - TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage - - {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever - the record wildcards '..' are used inside a constructor without labeled fields. - - Examples(s): None - - Test cases: None - -} - TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage - - {-| TcRnIgnoringAnnotations is a warning that occurs when the source code - contains annotation pragmas but the platform in use does not support an - external interpreter such as GHCi and therefore the annotations are ignored. - - Example(s): None - - Test cases: None - -} - TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage - - {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas - are used in conjunction with Safe Haskell. - - Example(s): None - - Test cases: annotations/should_fail/T10826 - -} - TcRnAnnotationInSafeHaskell :: TcRnMessage - - {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application - is used with an expression that does not accept "specified" type arguments. - - Example(s): - foo :: forall {a}. a -> a - foo x = x - bar :: () - bar = let x = foo @Int 42 - in () - - Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 - typecheck/should_fail/ExplicitSpecificity1 - typecheck/should_fail/ExplicitSpecificity10 - typecheck/should_fail/ExplicitSpecificity2 - typecheck/should_fail/T17173 - typecheck/should_fail/VtaFail - -} - TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage - - {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' - function is not applied to a single value argument. - - Example(s): - tagToEnum# 1 2 - - Test cases: None - -} - TcRnTagToEnumMissingValArg :: TcRnMessage - - {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' - function is not given a concrete result type. - - Example(s): - foo :: forall a. a - foo = tagToEnum# 0# - - Test cases: typecheck/should_fail/tcfail164 - -} - TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage - - {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' - function is given a result type that is not an enumeration type. - - Example(s): - foo :: Int -- not an enumeration TyCon - foo = tagToEnum# 0# - - Test cases: typecheck/should_fail/tcfail164 - -} - TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage - - {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the - predicate type of an ifThenElse expression in arrow notation depends on - the type of the result. - - Example(s): None - - Test cases: None - -} - TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage - - {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file - contains declarations that are not allowed, such as bindings. - - Example(s): None - - Test cases: None - -} - TcRnIllegalHsBootFileDecl :: TcRnMessage - - {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym - is defined in terms of itself, either directly or indirectly. - - Example(s): - pattern A = B - pattern B = A - - Test cases: patsyn/should_fail/T16900 - -} - TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage - - {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature - attempts to unify two different types. - - Example(s): - f :: a -> b -> _ - f x y = [x, y] - - Test cases: partial-sigs/should_fail/T14449 - -} - TcRnPartialTypeSigTyVarMismatch - :: Name -- ^ first type variable - -> Name -- ^ second type variable - -> Name -- ^ function name - -> LHsSigWcType GhcRn -> TcRnMessage - - {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable - being quantified over in the partial type signature of a function gets unified - with a type that is free in that function's context. - - Example(s): - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - Test cases: partial-sig/should_fail/T14479 - -} - TcRnPartialTypeSigBadQuantifier - :: Name -- ^ user-written name of type variable being quantified - -> Name -- ^ function name - -> Maybe Type -- ^ type the variable unified with, if known - -> LHsSigWcType GhcRn -- ^ partial type signature - -> TcRnMessage - - {-| TcRnMissingSignature is a warning that occurs when a top-level binding - or a pattern synonym does not have a type signature. - - Controlled by the flags: - -Wmissing-signatures - -Wmissing-exported-signatures - -Wmissing-pattern-synonym-signatures - -Wmissing-exported-pattern-synonym-signatures - -Wmissing-kind-signatures - - Test cases: - T11077 (top-level bindings) - T12484 (pattern synonyms) - T19564 (kind signatures) - -} - TcRnMissingSignature :: MissingSignature - -> Exported - -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures, - -- or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures - -> TcRnMessage - - {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures - that occurs when a local polymorphic binding lacks a type signature. - - Example(s): - id a = a - - Test cases: warnings/should_compile/T12574 - -} - TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage - - {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts - with the monomorphism restriction. - - Example(s): - data T a = T a - mono = ... where - x :: Applicative f => f a - T x = ... - - Test cases: typecheck/should_compile/T11339 - -} - TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage - - {-| TcRnTupleConstraintInst is an error that occurs whenever an instance - for a tuple constraint is specified. - - Examples(s): - class C m a - class D m a - f :: (forall a. Eq a => (C m a, D m a)) => m a - f = undefined - - Test cases: quantified-constraints/T15334 - -} - TcRnTupleConstraintInst :: !Class -> TcRnMessage - - {-| TcRnAbstractClassInst is an error that occurs whenever an instance - of an abstract class is specified. - - Examples(s): - -- A.hs-boot - module A where - class C a - - -- B.hs - module B where - import {-# SOURCE #-} A - instance C Int where - - -- A.hs - module A where - import B - class C a where - f :: a - - -- Main.hs - import A - main = print (f :: Int) - - Test cases: typecheck/should_fail/T13068 - -} - TcRnAbstractClassInst :: !Class -> TcRnMessage - - {-| TcRnNoClassInstHead is an error that occurs whenever an instance - head is not headed by a class. - - Examples(s): - instance c - - Test cases: typecheck/rename/T5513 - typecheck/rename/T16385 - -} - TcRnNoClassInstHead :: !Type -> TcRnMessage - - {-| TcRnUserTypeError is an error that occurs due to a user's custom type error, - which can be triggered by adding a `TypeError` constraint in a type signature - or typeclass instance. - - Examples(s): - f :: TypeError (Text "This is a type error") - f = undefined - - Test cases: typecheck/should_fail/CustomTypeErrors02 - typecheck/should_fail/CustomTypeErrors03 - -} - TcRnUserTypeError :: !Type -> TcRnMessage - - {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified - in a kind. - - Examples(s): - data Q :: Eq a => Type where {} - - Test cases: dependent/should_fail/T13895 - polykinds/T16263 - saks/should_fail/saks_fail004 - typecheck/should_fail/T16059a - typecheck/should_fail/T18714 - -} - TcRnConstraintInKind :: !Type -> TcRnMessage - - {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple - or unboxed sum type is specified as a function argument, when the appropriate - extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled. - - Examples(s): - -- T15073.hs - import T15073a - newtype Foo a = MkFoo a - deriving P - - -- T15073a.hs - class P a where - p :: a -> (# a #) - - Test cases: deriving/should_fail/T15073.hs - deriving/should_fail/T15073a.hs - typecheck/should_fail/T16059d - -} - TcRnUnboxedTupleOrSumTypeFuncArg - :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum - -> !Type - -> TcRnMessage - - {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is - specified in a kind. - - Examples(s): - data A :: * %1 -> * - - Test cases: linear/should_fail/LinearKind - linear/should_fail/LinearKind2 - linear/should_fail/LinearKind3 - -} - TcRnLinearFuncInKind :: !Type -> TcRnMessage - - {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind - mentions quantified type variable. - - Examples(s): - type T :: TYPE (BoxedRep l) - data T = MkT - - Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly - -} - TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage - - {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification - is specified in the type of a term. - - Examples(s): - a = (undefined :: forall k -> k -> Type) @Int - - Test cases: dependent/should_fail/T15859 - dependent/should_fail/T16326_Fail1 - dependent/should_fail/T16326_Fail2 - dependent/should_fail/T16326_Fail3 - dependent/should_fail/T16326_Fail4 - dependent/should_fail/T16326_Fail5 - dependent/should_fail/T16326_Fail6 - dependent/should_fail/T16326_Fail7 - dependent/should_fail/T16326_Fail8 - dependent/should_fail/T16326_Fail9 - dependent/should_fail/T16326_Fail10 - dependent/should_fail/T16326_Fail11 - dependent/should_fail/T16326_Fail12 - dependent/should_fail/T17687 - dependent/should_fail/T18271 - -} - TcRnVDQInTermType :: !Type -> TcRnMessage - - {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate - lacks a class or type variable head. - - Examples(s): - class (forall a. A t a => A t [a]) => B t where - type A t a :: Constraint - - Test cases: quantified-constraints/T16474 - -} - TcRnBadQuantPredHead :: !Type -> TcRnMessage - - {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple - constraint is specified. - - Examples(s): - g :: ((Show a, Num a), Eq a) => a -> a - g = undefined - - Test cases: typecheck/should_fail/tcfail209a - -} - TcRnIllegalTupleConstraint :: !Type -> TcRnMessage - - {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable - argument is specified in a constraint. - - Examples(s): - data T - instance Eq Int => Eq T - - Test cases: ghci/scripts/T13202 - ghci/scripts/T13202a - polykinds/T12055a - typecheck/should_fail/T10351 - typecheck/should_fail/T19187 - typecheck/should_fail/T6022 - typecheck/should_fail/T8883 - -} - TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage - - {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit - parameter is specified. - - Examples(s): - type Bla = ?x::Int - data T = T - instance Bla => Eq T - - Test cases: polykinds/T11466 - typecheck/should_fail/T8912 - typecheck/should_fail/tcfail041 - typecheck/should_fail/tcfail211 - typecheck/should_fail/tcrun045 - -} - TcRnIllegalImplicitParam :: !Type -> TcRnMessage - - {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint - synonym of kind is specified. - - Examples(s): - type Showish = Show - f :: (Showish a) => a -> a - f = undefined - - Test cases: typecheck/should_fail/tcfail209 - -} - TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage - - {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified - for a non-class. - - Examples(s): - type C1 a = (Show (a -> Bool)) - instance C1 Int where - - Test cases: polykinds/T13267 - -} - TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage - - {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated - visible kind argument is specified. - - Examples(s): - type family - F2 :: forall (a :: Type). Type where - F2 @a = Maybe a - - Test cases: typecheck/should_fail/T15793 - typecheck/should_fail/T16255 - -} - TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage - - {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an - associated type. - - Examples(s): - $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo) - [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)] - return [d]) - ======> - instance Eq Foo where - type Rep Foo = Maybe - - Test cases: th/T12387a - -} - TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> TcRnMessage - - {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type - is specified. - - Examples(s): - foo :: (a,b) -> (a~b => t) -> (a,b) - foo p x = p - - Test cases: - - ghci/should_run/T15806 - - indexed-types/should_fail/SimpleFail15 - - typecheck/should_fail/T11355 - - typecheck/should_fail/T12083a - - typecheck/should_fail/T12083b - - typecheck/should_fail/T16059c - - typecheck/should_fail/T16059e - - typecheck/should_fail/T17213 - - typecheck/should_fail/T18939_Fail - - typecheck/should_fail/T2538 - - typecheck/should_fail/T5957 - - typecheck/should_fail/T7019 - - typecheck/should_fail/T7019a - - typecheck/should_fail/T7809 - - typecheck/should_fail/T9196 - - typecheck/should_fail/tcfail127 - - typecheck/should_fail/tcfail184 - - typecheck/should_fail/tcfail196 - - typecheck/should_fail/tcfail197 - -} - TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage - - {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) - that arise when the monomorphism restriction applies to the given bindings. - - Examples(s): - {-# OPTIONS_GHC -Wmonomorphism-restriction #-} - - bar = 10 - - foo :: Int - foo = bar - - main :: IO () - main = print foo - - The example above emits the warning (for 'bar'), because without monomorphism - restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us - that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar' - less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that. - - Test cases: typecheck/should_compile/T13785 - -} - TcRnMonomorphicBindings :: [Name] -> TcRnMessage - - {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans) - that arises when a typeclass instance is an \"orphan\", i.e. if it appears - in a module in which neither the class nor the type being instanced are - declared in the same module. - - Examples(s): None - - Test cases: warnings/should_compile/T9178 - typecheck/should_compile/T4912 - -} - TcRnOrphanInstance :: ClsInst -> TcRnMessage - - {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies - conflicts between instance declarations. - - Examples(s): None - - Test cases: typecheck/should_fail/T2307 - typecheck/should_fail/tcfail096 - typecheck/should_fail/tcfail202 - -} - TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage - - {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance - declarations. - - Examples(s): - class Foo a where - foo :: a -> Int - - instance Foo Int where - foo = id - - instance Foo Int where - foo = const 42 - - Test cases: cabal/T12733/T12733 - typecheck/should_fail/tcfail035 - typecheck/should_fail/tcfail023 - backpack/should_fail/bkpfail18 - typecheck/should_fail/TcNullaryTCFail - typecheck/should_fail/tcfail036 - typecheck/should_fail/tcfail073 - module/mod51 - module/mod52 - module/mod44 - -} - TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage - - {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting - family instance declarations. - - Examples(s): None. - - Test cases: indexed-types/should_fail/ExplicitForAllFams4b - indexed-types/should_fail/NoGood - indexed-types/should_fail/Over - indexed-types/should_fail/OverDirectThisMod - indexed-types/should_fail/OverIndirectThisMod - indexed-types/should_fail/SimpleFail11a - indexed-types/should_fail/SimpleFail11b - indexed-types/should_fail/SimpleFail11c - indexed-types/should_fail/SimpleFail11d - indexed-types/should_fail/SimpleFail2a - indexed-types/should_fail/SimpleFail2b - indexed-types/should_fail/T13092/T13092 - indexed-types/should_fail/T13092c/T13092c - indexed-types/should_fail/T14179 - indexed-types/should_fail/T2334A - indexed-types/should_fail/T2677 - indexed-types/should_fail/T3330b - indexed-types/should_fail/T4246 - indexed-types/should_fail/T7102a - indexed-types/should_fail/T9371 - polykinds/T7524 - typecheck/should_fail/UnliftedNewtypesOverlap - -} - TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage - - TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage - - {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that - occurs when a strictness annotation is applied to an unlifted type. - - Example(s): - data T = MkT !Int# -- Strictness flag has no effect on unlifted types - - Test cases: typecheck/should_compile/T20187a - typecheck/should_compile/T20187b - -} - TcRnBangOnUnliftedType :: !Type -> TcRnMessage - - {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has - more than one default declaration. - - Example: - default (Integer, Int) - default (Double, Float) -- 2nd default declaration not allowed - - Text cases: module/mod58 - -} - TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage - - {-| TcRnBadDefaultType is an error that occurs when a type used in a default - declaration does not have an instance for any of the applicable classes. - - Example(s): - data Foo - default (Foo) - - Test cases: typecheck/should_fail/T11974b - -} - TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage - - {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's - export list bundles a pattern synonym with a type that is not a proper - `data` or `newtype` construction. - - Example(s): - module Foo (MyClass(.., P)) where - pattern P = Nothing - class MyClass a where - foo :: a -> Int - - Test cases: patsyn/should_fail/export-class - -} - TcRnPatSynBundledWithNonDataCon :: TcRnMessage - - {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list - of a module has a pattern synonym bundled with a type that does not match - the type of the pattern synonym. - - Example(s): - module Foo (R(P,x)) where - data Q = Q Int - data R = R - pattern P{x} = Q x - - Text cases: patsyn/should_fail/export-ps-rec-sel - patsyn/should_fail/export-type-synonym - patsyn/should_fail/export-type - -} - TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage - - {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that - occurs when a module appears more than once in an export list. - - Example(s): - module Foo (module Bar, module Bar) - import Bar - - Text cases: None - -} - TcRnDupeModuleExport :: ModuleName -> TcRnMessage - - {-| TcRnExportedModNotImported is an error that occurs when an export list - contains a module that is not imported. - - Example(s): None - - Text cases: module/mod135 - module/mod8 - rename/should_fail/rnfail028 - backpack/should_fail/bkpfail48 - -} - TcRnExportedModNotImported :: ModuleName -> TcRnMessage - - {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs - when an export list contains a module that has no exports. - - Example(s): - module Foo (module Bar) where - import Bar () - - Test cases: None - -} - TcRnNullExportedModule :: ModuleName -> TcRnMessage - - {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that - occurs when a module does not have an explicit export list. - - Example(s): None - - Test cases: typecheck/should_fail/MissingExportList03 - -} - TcRnMissingExportList :: ModuleName -> TcRnMessage - - {-| TcRnExportHiddenComponents is an error that occurs when an export contains - constructor or class methods that are not visible. - - Example(s): None - - Test cases: None - -} - TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage - - {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs - when an identifier appears in an export list more than once. - - Example(s): None - - Test cases: module/MultiExport - module/mod128 - module/mod14 - module/mod5 - overloadedrecflds/should_fail/DuplicateExports - patsyn/should_compile/T11959 - -} - TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage - - {-| TcRnExportedParentChildMismatch is an error that occurs when an export is - bundled with a parent that it does not belong to - - Example(s): - module Foo (T(a)) where - data T - a = True - - Test cases: module/T11970 - module/T11970B - module/mod17 - module/mod3 - overloadedrecflds/should_fail/NoParent - -} - TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage - - {-| TcRnConflictingExports is an error that occurs when different identifiers that - have the same name are being exported by a module. - - Example(s): - module Foo (Bar.f, module Baz) where - import qualified Bar (f) - import Baz (f) - - Test cases: module/mod131 - module/mod142 - module/mod143 - module/mod144 - module/mod145 - module/mod146 - module/mod150 - module/mod155 - overloadedrecflds/should_fail/T14953 - overloadedrecflds/should_fail/overloadedrecfldsfail10 - rename/should_fail/rnfail029 - rename/should_fail/rnfail040 - typecheck/should_fail/T16453E2 - typecheck/should_fail/tcfail025 - typecheck/should_fail/tcfail026 - -} - TcRnConflictingExports - :: OccName -- ^ Occurrence name shared by both exports - -> GreName -- ^ Name of first export - -> GlobalRdrElt -- ^ Provenance for definition site of first export - -> IE GhcPs -- ^ Export decl of first export - -> GreName -- ^ Name of second export - -> GlobalRdrElt -- ^ Provenance for definition site of second export - -> IE GhcPs -- ^ Export decl of second export - -> TcRnMessage - - {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring - when a record update's type cannot be precisely determined. This will not - be supported by -XDuplicateRecordFields in future releases. - - Example(s): - data Person = MkPerson { personId :: Int, name :: String } - data Address = MkAddress { personId :: Int, address :: String } - bad1 x = x { personId = 4 } :: Person -- ambiguous - bad2 (x :: Person) = x { personId = 4 } -- ambiguous - good x = (x :: Person) { personId = 4 } -- not ambiguous - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 - -} - TcRnAmbiguousField - :: HsExpr GhcRn -- ^ Field update - -> TyCon -- ^ Record type - -> TcRnMessage - - {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring - when the intialisation of a record is missing one or more (lazy) fields. - - Example(s): - data Rec = Rec { a :: Int, b :: String, c :: Bool } - x = Rec { a = 1, b = "two" } -- missing field 'c' - - Test cases: deSugar/should_compile/T13870 - deSugar/should_compile/ds041 - patsyn/should_compile/T11283 - rename/should_compile/T5334 - rename/should_compile/T12229 - rename/should_compile/T5892a - warnings/should_fail/WerrorFail2 - -} - TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage - - {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's - type mentions something that is outside the universally quantified variables - of the data constructor, such as an existentially quantified type. - - Example(s): - data X = forall a. MkX { f :: a } - x = (MkX ()) { f = False } - - Test cases: patsyn/should_fail/records-exquant - typecheck/should_fail/T3323 - -} - TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage - - {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update - has fields that no single constructor encompasses. - - Example(s): - data Foo = A { x :: Bool } - | B { y :: Int } - foo = (A False) { x = True, y = 5 } - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08 - patsyn/should_fail/mixed-pat-syn-record-sels - typecheck/should_fail/T7989 - -} - TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage - - {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and - record selectors are used in the same record update block. - - Example(s): - data Rec = Rec { foo :: Int, bar :: String } - pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 } - illegal :: Rec -> Rec - illegal r = r { f1 = 1, bar = "two" } - - Test cases: patsyn/should_fail/records-mixing-fields - -} - TcRnMixedSelectors - :: Name -- ^ Record - -> [Id] -- ^ Record selectors - -> Name -- ^ Pattern synonym - -> [Id] -- ^ Pattern selectors - -> TcRnMessage - - {- TcRnMissingStrictFields is an error occurring when a record field marked - as strict is omitted when constructing said record. - - Example(s): - data R = R { strictField :: !Bool, nonStrict :: Int } - x = R { nonStrict = 1 } - - Test cases: typecheck/should_fail/T18869 - typecheck/should_fail/tcfail085 - typecheck/should_fail/tcfail112 - -} - TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage - - {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a - record update block do not all belong to any one type. - - Example(s): - data R1 = R1 { x :: Int, y :: Int } - data R2 = R2 { y :: Int, z :: Int } - update r = r { x = 1, y = 2, z = 3 } - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - overloadedrecflds/should_fail/overloadedrecfldsfail14 - -} - TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage - - {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot - be pinned down to any one constructor and thus must be given a type signature. - - Example(s): - data R1 = R1 { x :: Int } - data R2 = R2 { x :: Int } - update r = r { x = 1 } -- needs a type signature - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - -} - TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage - - {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static - using the -XStaticPointers extension but which are not closed terms. - - Example(s): - f x = static x - - Test cases: rename/should_fail/RnStaticPointersFail01 - rename/should_fail/RnStaticPointersFail03 - -} - TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage - {-| TcRnSpecialClassInst is an error that occurs when a user - attempts to define an instance for a built-in typeclass such as - 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file. - - Test cases: deriving/should_fail/T9687 - deriving/should_fail/T14916 - polykinds/T8132 - typecheck/should_fail/TcCoercibleFail2 - typecheck/should_fail/T12837 - typecheck/should_fail/T14390 - - -} - TcRnSpecialClassInst :: !Class - -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled - -> TcRnMessage - - {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that - occurs when trying to derive an instance of the 'Typeable' class. Deriving - 'Typeable' is no longer necessary (hence the \"useless\") as all types - automatically derive 'Typeable' in modern GHC versions. - - Example(s): None. - - Test cases: warnings/should_compile/DerivingTypeable - -} - TcRnUselessTypeable :: TcRnMessage - - {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that - occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are - enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not - be what the user wants. - - Example(s): None. - - Test cases: typecheck/should_compile/T15839a - deriving/should_compile/T16179 - -} - TcRnDerivingDefaults :: !Class -> TcRnMessage - - {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC - encounters a non-unary constraint when trying to derive a typeclass. - - Example(s): - class A - deriving instance A - data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). - - Test cases: deriving/should_fail/T7959 - deriving/should_fail/drvfail005 - deriving/should_fail/drvfail009 - deriving/should_fail/drvfail006 - -} - TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage - - {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) - that occurs when a wildcard '_' is found in place of a type in a signature or a - type class derivation - - Example(s): - foo :: _ -> Int - foo = ... - - deriving instance _ => Eq (Foo a) - - Test cases: dependent/should_compile/T11241 - dependent/should_compile/T15076 - dependent/should_compile/T14880-2 - typecheck/should_compile/T17024 - typecheck/should_compile/T10072 - partial-sigs/should_fail/TidyClash2 - partial-sigs/should_fail/Defaulting1MROff - partial-sigs/should_fail/WildcardsInPatternAndExprSig - partial-sigs/should_fail/T10615 - partial-sigs/should_fail/T14584a - partial-sigs/should_fail/TidyClash - partial-sigs/should_fail/T11122 - partial-sigs/should_fail/T14584 - partial-sigs/should_fail/T10045 - partial-sigs/should_fail/PartialTypeSignaturesDisabled - partial-sigs/should_fail/T10999 - partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature - partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice - partial-sigs/should_fail/WildcardInstantiations - partial-sigs/should_run/T15415 - partial-sigs/should_compile/T10463 - partial-sigs/should_compile/T15039a - partial-sigs/should_compile/T16728b - partial-sigs/should_compile/T15039c - partial-sigs/should_compile/T10438 - partial-sigs/should_compile/SplicesUsed - partial-sigs/should_compile/T18008 - partial-sigs/should_compile/ExprSigLocal - partial-sigs/should_compile/T11339a - partial-sigs/should_compile/T11670 - partial-sigs/should_compile/WarningWildcardInstantiations - partial-sigs/should_compile/T16728 - partial-sigs/should_compile/T12033 - partial-sigs/should_compile/T15039b - partial-sigs/should_compile/T10403 - partial-sigs/should_compile/T11192 - partial-sigs/should_compile/T16728a - partial-sigs/should_compile/TypedSplice - partial-sigs/should_compile/T15039d - partial-sigs/should_compile/T11016 - partial-sigs/should_compile/T13324_compile2 - linear/should_fail/LinearPartialSig - polykinds/T14265 - polykinds/T14172 - -} - TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage - - {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance - can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason - this error arose. - - Example(s): None. - - Test cases: generics/T10604/T10604_no_PolyKinds - deriving/should_fail/drvfail009 - deriving/should_fail/drvfail-functor2 - deriving/should_fail/T10598_fail3 - deriving/should_fail/deriving-via-fail2 - deriving/should_fail/deriving-via-fail - deriving/should_fail/T16181 - -} - TcRnCannotDeriveInstance :: !Class - -- ^ The typeclass we are trying to derive - -- an instance for - -> [Type] - -- ^ The typeclass arguments, if any. - -> !(Maybe (DerivStrategy GhcTc)) - -- ^ The derivation strategy, if any. - -> !UsingGeneralizedNewtypeDeriving - -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? - -> !DeriveInstanceErrReason - -- ^ The specific reason why we couldn't derive - -- an instance for the class. - -> TcRnMessage - - {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested - GADT pattern match inside a lazy (~) pattern. - - Test case: gadt/lazypat - -} - TcRnLazyGADTPattern :: TcRnMessage - - {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a - GADT pattern inside arrow proc notation. - - Test case: arrows/should_fail/arrowfail004. - -} - TcRnArrowProcGADTPattern :: TcRnMessage - - {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs - when a definition uses 'forall' as an identifier. - - Example: - forall x = () - g forall = () - - Test cases: T20609 T20609a T20609b T20609c T20609d - -} - TcRnForallIdentifier :: RdrName -> TcRnMessage - - {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope) - that occurs when the type equality (a ~ b) is not in scope. - - Test case: T18862b - -} - TcRnTypeEqualityOutOfScope :: TcRnMessage - - {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators) - that occurs when the type equality (a ~ b) is used without the TypeOperators extension. - - Example: - {-# LANGUAGE NoTypeOperators #-} - f :: (a ~ b) => a -> b - - Test case: T18862a - -} - TcRnTypeEqualityRequiresOperators :: TcRnMessage - - {-| TcRnIllegalTypeOperator is an error that occurs when a type operator - is used without the TypeOperators extension. - - Example: - {-# LANGUAGE NoTypeOperators #-} - f :: Vec a n -> Vec a m -> Vec a (n + m) - - Test case: T12811 - -} - TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage - - {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds - that occurs when pattern matching on a GADT when -XMonoLocalBinds is off. - - Example(s): None - - Test cases: T20485, T20485a - -} - TcRnGADTMonoLocalBinds :: TcRnMessage - {-| The TcRnNotInScope constructor is used for various not-in-scope errors. - See 'NotInScopeError' for more details. -} - TcRnNotInScope :: NotInScopeError -- ^ what the problem is - -> RdrName -- ^ the name that is not in scope - -> [ImportError] -- ^ import errors that are relevant - -> [GhcHint] -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor - -> TcRnMessage - - {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors) - that is triggered by an unticked occurrence of a promoted data constructor. - - Examples: - - data A = MkA - type family F (a :: A) where { F MkA = Bool } - - type B = [ Int, Bool ] - - Test cases: T9778, T19984. - -} - TcRnUntickedPromotedThing :: UntickedPromotedThing - -> TcRnMessage - - {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears - in an unexpected location, e.g. as a data constructor or in a fixity declaration. - - Examples: - - infixl 5 : - - data P = (,) - - Test cases: rnfail042, T14907b, T15124, T15233. - -} - TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...) - -> RdrName - -> TcRnMessage - -- TODO: remove the SDoc argument. - - {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) - that is triggered whenever a Wanted typeclass constraint - is solving through the defaulting of a type variable. - - Example: - - one = show 1 - -- We get Wanteds Show a0, Num a0, and default a0 to Integer. - - Test cases: - none (which are really specific to defaulting), - but see e.g. tcfail204. - -} - TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred - -> Maybe TyVar -- ^ The type variable being defaulted - -> Type -- ^ The default type - -> TcRnMessage - - {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' - is used in the incorrect 'NameSpace', e.g. a type constructor - or class used in a term, or a term variable used in a type. - - Example: - - f x = Int - - Test cases: T18740a, T20884. - -} - TcRnIncorrectNameSpace :: Name - -> Bool -- ^ whether the error is happening - -- in a Template Haskell tick - -- (so we should give a Template Haskell hint) - -> TcRnMessage - - {- TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import - is declared using the @prim@ calling convention without having turned on - the -XGHCForeignImportPrim extension. - - Example(s): - foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) - - Test cases: ffi/should_fail/T20116 - -} - TcRnForeignImportPrimExtNotSet :: ForeignImport -> TcRnMessage - - {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe - annotation should not be used with @prim@ foreign imports. - - Example(s): - foreign import prim unsafe "my_primop_cmm" :: ... - - Test cases: None - -} - TcRnForeignImportPrimSafeAnn :: ForeignImport -> TcRnMessage - - {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ - imports cannot have function types. - - Example(s): - foreign import capi "math.h value sqrt" f :: CInt -> CInt - - Test cases: ffi/should_fail/capi_value_function - -} - TcRnForeignFunctionImportAsValue :: ForeignImport -> TcRnMessage - - {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ - that informs the user of a possible missing @&@ in the declaration of a - foreign import with a 'FunPtr' return type. - - Example(s): - foreign import ccall "f" f :: FunPtr (Int -> IO ()) - - Test cases: ffi/should_compile/T1357 - -} - TcRnFunPtrImportWithoutAmpersand :: ForeignImport -> TcRnMessage - - {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration - is not compatible with the code generation backend being used. - - Example(s): None - - Test cases: None - -} - TcRnIllegalForeignDeclBackend - :: Either ForeignExport ForeignImport - -> Backend - -> ExpectedBackends - -> TcRnMessage - - {- TcRnUnsupportedCallConv informs the user that the calling convention specified - for a foreign export declaration is not compatible with the target platform. - It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of - @stdcall@ but is otherwise considered an error. - - Example(s): None - - Test cases: None - -} - TcRnUnsupportedCallConv :: Either ForeignExport ForeignImport -> UnsupportedCallConvention -> TcRnMessage - - {- TcRnIllegalForeignType is an error for when a type appears in a foreign - function signature that is not compatible with the FFI. - - Example(s): None - - Test cases: ffi/should_fail/T3066 - ffi/should_fail/ccfail004 - ffi/should_fail/T10461 - ffi/should_fail/T7506 - ffi/should_fail/T5664 - safeHaskell/ghci/p6 - safeHaskell/safeLanguage/SafeLang08 - ffi/should_fail/T16702 - linear/should_fail/LinearFFI - ffi/should_fail/T7243 - -} - TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage - - {- TcRnInvalidCIdentifier indicates a C identifier that is not valid. - - Example(s): - foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# - - Test cases: th/T10638 - -} - TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage - - {- TcRnCannotDefaultConcrete is an error occurring when a concrete - type variable cannot be defaulted. - - Test cases: - T23153 - -} - TcRnCannotDefaultConcrete - :: !FixedRuntimeRepOrigin - -> TcRnMessage - --- | Specifies which backend code generators where expected for an FFI declaration -data ExpectedBackends - = COrAsmOrLlvm -- ^ C, Asm, or LLVM - | COrAsmOrLlvmOrInterp -- ^ C, Asm, LLVM, or interpreted - deriving Eq - --- | Specifies which calling convention is unsupported on the current platform -data UnsupportedCallConvention - = StdCallConvUnsupported - | PrimCallConvUnsupported - | JavaScriptCallConvUnsupported - deriving Eq - --- | Whether the error pertains to a function argument or a result. -data ArgOrResult - = Arg | Result - --- | Which parts of a record field are affected by a particular error or warning. -data RecordFieldPart - = RecordFieldConstructor !Name - | RecordFieldPattern !Name - | RecordFieldUpdate - --- | Where a shadowed name comes from -data ShadowedNameProvenance - = ShadowedNameProvenanceLocal !SrcLoc - -- ^ The shadowed name is local to the module - | ShadowedNameProvenanceGlobal [GlobalRdrElt] - -- ^ The shadowed name is global, typically imported from elsewhere. - --- | In what context did we require a type to have a fixed runtime representation? --- --- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing --- representation polymorphism errors when validity checking. --- --- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete -data FixedRuntimeRepProvenance - -- | Data constructor fields must have a fixed runtime representation. - -- - -- Tests: T11734, T18534. - = FixedRuntimeRepDataConField - - -- | Pattern synonym signature arguments must have a fixed runtime representation. - -- - -- Test: RepPolyPatSynArg. - | FixedRuntimeRepPatSynSigArg - - -- | Pattern synonym signature scrutinee must have a fixed runtime representation. - -- - -- Test: RepPolyPatSynRes. - | FixedRuntimeRepPatSynSigRes - -pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc -pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field" -pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument" -pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee" - --- | Why the particular injectivity error arose together with more information, --- if any. -data InjectivityErrReason - = InjErrRhsBareTyVar [Type] - | InjErrRhsCannotBeATypeFam - | InjErrRhsOverlap - | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances - -data HasKinds - = YesHasKinds - | NoHasKinds - deriving (Show, Eq) - -hasKinds :: Bool -> HasKinds -hasKinds True = YesHasKinds -hasKinds False = NoHasKinds - -data SuggestUndecidableInstances - = YesSuggestUndecidableInstaces - | NoSuggestUndecidableInstaces - deriving (Show, Eq) - -suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances -suggestUndecidableInstances True = YesSuggestUndecidableInstaces -suggestUndecidableInstances False = NoSuggestUndecidableInstaces - --- | A data type to describe why a variable is not closed. --- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - -data SuggestPartialTypeSignatures - = YesSuggestPartialTypeSignatures - | NoSuggestPartialTypeSignatures - deriving (Show, Eq) - -suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures -suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures -suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures - -data UsingGeneralizedNewtypeDeriving - = YesGeneralizedNewtypeDeriving - | NoGeneralizedNewtypeDeriving - deriving Eq - -usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving -usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving -usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving - -data DeriveAnyClassEnabled - = YesDeriveAnyClassEnabled - | NoDeriveAnyClassEnabled - deriving Eq - -deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled -deriveAnyClassEnabled True = YesDeriveAnyClassEnabled -deriveAnyClassEnabled False = NoDeriveAnyClassEnabled - --- | Why a particular typeclass instance couldn't be derived. -data DeriveInstanceErrReason - = - -- | The typeclass instance is not well-kinded. - DerivErrNotWellKinded !TyCon - -- ^ The type constructor that occurs in - -- the typeclass instance declaration. - !Kind - -- ^ The typeclass kind. - !Int - -- ^ The number of typeclass arguments that GHC - -- kept. See Note [tc_args and tycon arity] in - -- GHC.Tc.Deriv. - -- | Generic instances can only be derived using the stock strategy - -- in Safe Haskell. - | DerivErrSafeHaskellGenericInst - | DerivErrDerivingViaWrongKind !Kind !Type !Kind - | DerivErrNoEtaReduce !Type - -- ^ The instance type - -- | We cannot derive instances in boot files - | DerivErrBootFileFound - | DerivErrDataConsNotAllInScope !TyCon - -- | We cannot use GND on non-newtype types - | DerivErrGNDUsedOnData - -- | We cannot derive instances of nullary classes - | DerivErrNullaryClasses - -- | Last arg must be newtype or data application - | DerivErrLastArgMustBeApp - | DerivErrNoFamilyInstance !TyCon [Type] - | DerivErrNotStockDeriveable !DeriveAnyClassEnabled - | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts - !AssociatedTyLastVarInKind - !AssociatedTyNotParamOverLastTyVar - | DerivErrNewtypeNonDeriveableClass - | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? - | DerivErrOnlyAnyClassDeriveable !TyCon - -- ^ Type constructor for which the instance - -- is requested - !DeriveAnyClassEnabled - -- ^ Whether or not -XDeriveAnyClass is enabled - -- already. - -- | Stock deriving won't work, but perhas DeriveAnyClass will. - | DerivErrNotDeriveable !DeriveAnyClassEnabled - -- | The given 'PredType' is not a class. - | DerivErrNotAClass !PredType - -- | The given (representation of the) 'TyCon' has no - -- data constructors. - | DerivErrNoConstructors !TyCon - | DerivErrLangExtRequired !LangExt.Extension - -- | GHC simply doesn't how to how derive the input 'Class' for the given - -- 'Type'. - | DerivErrDunnoHowToDeriveForType !Type - -- | The given 'TyCon' must be an enumeration. - -- See Note [Enumeration types] in GHC.Core.TyCon - | DerivErrMustBeEnumType !TyCon - -- | The given 'TyCon' must have /precisely/ one constructor. - | DerivErrMustHaveExactlyOneConstructor !TyCon - -- | The given data type must have some parameters. - | DerivErrMustHaveSomeParameters !TyCon - -- | The given data type must not have a class context. - | DerivErrMustNotHaveClassContext !TyCon !ThetaType - -- | We couldn't derive an instance for a particular data constructor - -- for a variety of reasons. - | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] - -- | We couldn't derive a 'Generic' instance for the given type for a - -- variety of reasons - | DerivErrGenerics [DeriveGenericsErrReason] - -- | We couldn't derive an instance either because the type was not an - -- enum type or because it did have more than one constructor. - | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason - -data DeriveInstanceBadConstructor - = - -- | The given 'DataCon' must be truly polymorphic in the - -- last argument of the data type. - DerivErrBadConExistential !DataCon - -- | The given 'DataCon' must not use the type variable in a function argument" - | DerivErrBadConCovariant !DataCon - -- | The given 'DataCon' must not contain function types - | DerivErrBadConFunTypes !DataCon - -- | The given 'DataCon' must use the type variable only - -- as the last argument of a data type - | DerivErrBadConWrongArg !DataCon - -- | The given 'DataCon' is a GADT so we cannot directly - -- derive an istance for it. - | DerivErrBadConIsGADT !DataCon - -- | The given 'DataCon' has existentials type vars in its type. - | DerivErrBadConHasExistentials !DataCon - -- | The given 'DataCon' has constraints in its type. - | DerivErrBadConHasConstraints !DataCon - -- | The given 'DataCon' has a higher-rank type. - | DerivErrBadConHasHigherRankType !DataCon - -data DeriveGenericsErrReason - = -- | The type must not have some datatype context. - DerivErrGenericsMustNotHaveDatatypeContext !TyCon - -- | The data constructor must not have exotic unlifted - -- or polymorphic arguments. - | DerivErrGenericsMustNotHaveExoticArgs !DataCon - -- | The data constructor must be a vanilla constructor. - | DerivErrGenericsMustBeVanillaDataCon !DataCon - -- | The type must have some type parameters. - -- check (d) from Note [Requirements for deriving Generic and Rep] - -- in GHC.Tc.Deriv.Generics. - | DerivErrGenericsMustHaveSomeTypeParams !TyCon - -- | The data constructor must not have existential arguments. - | DerivErrGenericsMustNotHaveExistentials !DataCon - -- | The derivation applies a type to an argument involving - -- the last parameter but the applied type is not of kind * -> *. - | DerivErrGenericsWrongArgKind !DataCon - -data HasWildcard - = YesHasWildcard - | NoHasWildcard - deriving Eq - -hasWildcard :: Bool -> HasWildcard -hasWildcard True = YesHasWildcard -hasWildcard False = NoHasWildcard - --- | A context in which we don't allow anonymous wildcards. -data BadAnonWildcardContext - = WildcardNotLastInConstraint - | ExtraConstraintWildcardNotAllowed - SoleExtraConstraintWildcardAllowed - | WildcardsNotAllowedAtAll - --- | Whether a sole extra-constraint wildcard is allowed, --- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. -data SoleExtraConstraintWildcardAllowed - = SoleExtraConstraintWildcardNotAllowed - | SoleExtraConstraintWildcardAllowed - --- | A type representing whether or not the input type has associated data family instances. -data HasAssociatedDataFamInsts - = YesHasAdfs - | NoHasAdfs - deriving Eq - -hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts -hasAssociatedDataFamInsts True = YesHasAdfs -hasAssociatedDataFamInsts False = NoHasAdfs - --- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass --- contains the last type variable of the class in a kind, which is not (yet) allowed --- by GHC. -data AssociatedTyLastVarInKind - = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class - | NoAssocTyLastVarInKind - deriving Eq - -associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind -associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc -associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind - --- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a --- typeclass is not parameterized over the last type variable of the class -data AssociatedTyNotParamOverLastTyVar - = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class - | NoAssociatedTyNotParamOverLastTyVar - deriving Eq - -associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar -associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc -associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar - --- | What kind of thing is missing a type signature? --- --- Used for reporting @"missing signature"@ warnings, see --- 'tcRnMissingSignature'. -data MissingSignature - = MissingTopLevelBindingSig Name Type - | MissingPatSynSig PatSyn - | MissingTyConKindSig - TyCon - Bool -- ^ whether -XCUSKs is enabled - --- | Is the object we are dealing with exported or not? --- --- Used for reporting @"missing signature"@ warnings, see --- 'TcRnMissingSignature'. -data Exported - = IsNotExported - | IsExported - -instance Outputable Exported where - ppr IsNotExported = text "IsNotExported" - ppr IsExported = text "IsExported" - --------------------------------------------------------------------------------- --- --- Errors used in GHC.Tc.Errors --- --------------------------------------------------------------------------------- - -{- Note [Error report] -~~~~~~~~~~~~~~~~~~~~~~ -The idea is that error msgs are divided into three parts: the main msg, the -context block ("In the second argument of ..."), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. --} - --- | A collection of main error messages and supplementary information. --- --- In practice, we will: --- - display the important messages first, --- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), --- - then the supplementary information (e.g. relevant bindings, valid hole fits), --- - then the hints ("Possible fix: ..."). --- --- So this is mostly just a way of making sure that the error context appears --- early on rather than at the end of the message. --- --- See Note [Error report] for details. -data SolverReport - = SolverReport - { sr_important_msgs :: [SolverReportWithCtxt] - , sr_supplementary :: [SolverReportSupplementary] - , sr_hints :: [GhcHint] - } - --- | Additional information to print in a 'SolverReport', after the --- important messages and after the error context. --- --- See Note [Error report]. -data SolverReportSupplementary - = SupplementaryBindings RelevantBindings - | SupplementaryHoleFits ValidHoleFits - | SupplementaryCts [(PredType, RealSrcSpan)] - --- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) --- that are needed in order to report it. -data SolverReportWithCtxt = - SolverReportWithCtxt - { reportContext :: SolverReportErrCtxt - -- ^ Context for what we wish to report. - -- This can change as we enter implications, so is - -- stored alongside the content. - , reportContent :: TcSolverReportMsg - -- ^ The content of the message to report. - } - -instance Semigroup SolverReport where - SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2 - = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2) - -instance Monoid SolverReport where - mempty = SolverReport [] [] [] - mappend = (Semigroup.<>) - --- | Context needed when reporting a 'TcSolverReportMsg', such as --- the enclosing implication constraints or whether we are deferring type errors. -data SolverReportErrCtxt - = CEC { cec_encl :: [Implication] -- ^ Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- ^ We make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime - - -- We might throw a warning on an error when encountering a hole, - -- depending on the type of hole (expression hole, type hole, out of scope hole). - -- We store the reasons for reporting a diagnostic for each type of hole. - , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions. - , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types. - , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes. - - , cec_warn_redundant :: Bool -- ^ True <=> -Wredundant-constraints - , cec_expand_syns :: Bool -- ^ True <=> -fprint-expanded-synonyms - - , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -getUserGivens :: SolverReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - ----------------------------------------------------------------------------- --- --- ErrorItem --- ----------------------------------------------------------------------------- - --- | A predicate with its arising location; used to encapsulate a constraint --- that will give rise to a diagnostic. -data ErrorItem --- We could perhaps use Ct here (and indeed used to do exactly that), but --- having a separate type gives to denote errors-in-formation gives us --- a nice place to do pre-processing, such as calculating ei_suppress. --- Perhaps some day, an ErrorItem could eventually evolve to contain --- the error text (or some representation of it), so we can then have all --- the errors together when deciding which to report. - = EI { ei_pred :: PredType -- report about this - -- The ei_pred field will never be an unboxed equality with - -- a (casted) tyvar on the right; this is guaranteed by the solver - , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence - , ei_flavour :: CtFlavour - , ei_loc :: CtLoc - , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a - -- CtIrred, this stores the reason - , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Constraint - } - -instance Outputable ErrorItem where - ppr (EI { ei_pred = pred - , ei_evdest = m_evdest - , ei_flavour = flav - , ei_suppress = supp }) - = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred - where - pp_dest Nothing = empty - pp_dest (Just ev) = ppr ev <+> dcolon - - pp_supp = if supp then text "suppress:" else empty - -errorItemOrigin :: ErrorItem -> CtOrigin -errorItemOrigin = ctLocOrigin . ei_loc - -errorItemEqRel :: ErrorItem -> EqRel -errorItemEqRel = predTypeEqRel . ei_pred - -errorItemCtLoc :: ErrorItem -> CtLoc -errorItemCtLoc = ei_loc - -errorItemPred :: ErrorItem -> PredType -errorItemPred = ei_pred - -{- Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... --} - - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - - --- | An error reported after constraint solving. --- This is usually, some sort of unsolved constraint error, --- but we try to be specific about the precise problem we encountered. -data TcSolverReportMsg - -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors - -- to use the diagnostic infrastructure (TcRnMessage etc). - -- If you see possible improvements, please go right ahead! - - -- | Wrap a message with additional information. - -- - -- Prefer using the 'mkTcReportWithInfo' smart constructor - = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo) - - -- | Quantified variables appear out of dependency order. - -- - -- Example: - -- - -- forall (a :: k) k. ... - -- - -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. - | BadTelescope TyVarBndrs [TyCoVar] - - -- | We came across a custom type error and we have decided to report it. - -- - -- Example: - -- - -- type family F a where - -- F a = TypeError (Text "error") - -- - -- err :: F () - -- err = () - -- - -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. - | UserTypeError Type - - -- | We want to report an out of scope variable or a typed hole. - -- See 'HoleError'. - | ReportHoleError Hole HoleError - - -- | A type equality between a type variable and a polytype. - -- - -- Test cases: T12427a, T2846b, T10194, ... - | CannotUnifyWithPolytype ErrorItem TyVar Type - - -- | Couldn't unify two types or kinds. - -- - -- Example: - -- - -- 3 + 3# -- can't match a lifted type with an unlifted type - -- - -- Test cases: T1396, T8263, ... - | Mismatch - { mismatch_ea :: Bool -- ^ 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) - , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) - } - - -- | A type has an unexpected kind. - -- - -- Test cases: T2994, T7609, ... - | KindMismatch - { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? - , kmismatch_expected :: Type - , kmismatch_actual :: Type - } - -- TODO: combine 'Mismatch' and 'KindMismatch' messages. - - -- | A mismatch between two types, which arose from a type equality. - -- - -- Test cases: T1470, tcfail212. - | TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_item :: ErrorItem - , teq_mismatch_ty1 :: Type - , teq_mismatch_ty2 :: Type - , teq_mismatch_expected :: Type -- ^ The overall expected type - , teq_mismatch_actual :: Type -- ^ The overall actual type - , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? - } - -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages. - - -- | A violation of the representation-polymorphism invariants. - -- - -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. - | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] - - -- | A skolem type variable escapes its scope. - -- - -- Example: - -- - -- data Ex where { MkEx :: a -> MkEx } - -- foo (MkEx x) = x - -- - -- Test cases: TypeSkolEscape, T11142. - | SkolemEscape ErrorItem Implication [TyVar] - - -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. - -- - -- Test case: Simple14 - | UntouchableVariable TyVar Implication - - -- | An equality between two types is blocked on a kind equality - -- beteen their kinds. - -- - -- Test cases: none. - | BlockedEquality ErrorItem - - -- | Something was not applied to sufficiently many arguments. - -- - -- Example: - -- - -- instance Eq Maybe where {..} - -- - -- Test case: T11563. - | ExpectingMoreArguments Int TypedThing - - -- | Trying to use an unbound implicit parameter. - -- - -- Example: - -- - -- foo :: Int - -- foo = ?param - -- - -- Test case: tcfail130. - | UnboundImplicitParams - (NE.NonEmpty ErrorItem) - - -- | Couldn't solve some Wanted constraints using the Givens. - -- This is the most commonly used constructor, used for generic - -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages. - | CouldNotDeduce - { cnd_user_givens :: [Implication] - -- | The Wanted constraints we couldn't solve. - -- - -- N.B.: the 'ErrorItem' at the head of the list has been tidied, - -- perhaps not the others. - , cnd_wanted :: NE.NonEmpty ErrorItem - - -- | Some additional info consumed by 'mk_supplementary_ea_msg'. - , cnd_extra :: Maybe CND_Extra - } - - -- | A constraint couldn't be solved because it contains - -- ambiguous type variables. - -- - -- Example: - -- - -- class C a b where - -- f :: (a,b) - -- - -- x = fst f - -- - -- - -- Test case: T4921. - | AmbiguityPreventsSolvingCt - ErrorItem -- ^ always a class constraint - ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively - - -- | Could not solve a constraint; there were several unifying candidate instances - -- but no matching instances. This is used to report as much useful information - -- as possible about why we couldn't choose any instance, e.g. because of - -- ambiguous type variables. - | CannotResolveInstance - { cannotResolve_item :: ErrorItem - , cannotResolve_unifiers :: [ClsInst] - , cannotResolve_candidates :: [ClsInst] - , cannotResolve_importErrors :: [ImportError] - , cannotResolve_suggestions :: [GhcHint] - , cannotResolve_relevant_bindings :: RelevantBindings } - -- TODO: remove the fields of type [GhcHint] and RelevantBindings, - -- in order to handle them uniformly with other diagnostic messages. - - -- | Could not solve a constraint using available instances - -- because the instances overlap. - -- - -- Test cases: tcfail118, tcfail121, tcfail218. - | OverlappingInstances - { overlappingInstances_item :: ErrorItem - , overlappingInstances_matches :: [ClsInst] - , overlappingInstances_unifiers :: [ClsInst] } - - -- | Could not solve a constraint from instances because - -- instances declared in a Safe module cannot overlap instances - -- from other modules (with -XSafeHaskell). - -- - -- Test cases: SH_Overlap{1,2,5,6,7,11}. - | UnsafeOverlap - { unsafeOverlap_item :: ErrorItem - , unsafeOverlap_matches :: [ClsInst] - , unsafeOverlapped :: [ClsInst] } - --- | Additional information to be given in a 'CouldNotDeduce' message, --- which is then passed on to 'mk_supplementary_ea_msg'. -data CND_Extra = CND_Extra TypeOrKind Type Type - --- | Additional information that can be appended to an existing 'TcSolverReportMsg'. -data TcSolverReportInfo - -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors - -- to use the diagnostic infrastructure (TcRnMessage etc). - -- It would be better for these constructors to not be so closely tied - -- to the constructors of 'TcSolverReportMsg'. - -- If you see possible improvements, please go right ahead! - - -- | Some type variables remained ambiguous: print them to the user. - = Ambiguity - { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." - -- False <=> create a message of the form "The type variable is ambiguous." - , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. - -- Guaranteed to not both be empty. - } - - -- | Specify some information about a type variable, - -- e.g. its 'SkolemInfo'. - | TyVarInfo TyVar - - -- | Remind the user that a particular type family is not injective. - | NonInjectiveTyFam TyCon - - -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'. - | ReportCoercibleMsg CoercibleMsg - - -- | Display the expected and actual types. - | ExpectedActual - { ea_expected, ea_actual :: Type } - - -- | Display the expected and actual types, after expanding type synonyms. - | ExpectedActualAfterTySynExpansion - { ea_expanded_expected, ea_expanded_actual :: Type } - - -- | Explain how a kind equality originated. - | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) - - -- | Add some information to disambiguate errors in which - -- two 'Names' would otherwise appear to be identical. - -- - -- See Note [Disambiguating (X ~ X) errors]. - | SameOcc - { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. - , sameOcc_lhs :: Name - , sameOcc_rhs :: Name } - - -- | Report some type variables that might be participating in an occurs-check failure. - | OccursCheckInterestingTyVars (NE.NonEmpty TyVar) - --- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' --- constructor of 'HoleError'. -data NotInScopeError - - -- | A run-of-the-mill @"not in scope"@ error. - = NotInScope - - -- | An exact 'Name' was not in scope. - -- - -- This usually indicates a problem with a Template Haskell splice. - -- - -- Test cases: T5971, T18263. - | NoExactName Name - - -- The same exact 'Name' occurs in multiple name-spaces. - -- - -- This usually indicates a problem with a Template Haskell splice. - -- - -- Test case: T7241. - | SameName [GlobalRdrElt] -- ^ always at least 2 elements - - -- A type signature, fixity declaration, pragma, standalone kind signature... - -- is missing an associated binding. - | MissingBinding SDoc [GhcHint] - -- TODO: remove the SDoc argument. - - -- | Couldn't find a top-level binding. - -- - -- Happens when specifying an annotation for something that - -- is not in scope. - -- - -- Test cases: annfail01, annfail02, annfail11. - | NoTopLevelBinding - - -- | A class doesnt have a method with this name, - -- or, a class doesn't have an associated type with this name, - -- or, a record doesn't have a record field with this name. - | UnknownSubordinate SDoc - --- | Create a @"not in scope"@ error message for the given 'RdrName'. -mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage -mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints - --- | Configuration for pretty-printing valid hole fits. -data HoleFitDispConfig = - HFDC { showWrap, showWrapVars, showType, showProv, showMatches - :: Bool } - --- | Report an error involving a 'Hole'. --- --- This could be an out of scope data constructor or variable, --- a typed hole, or a wildcard in a type. -data HoleError - -- | Report an out-of-scope data constructor or variable - -- masquerading as an expression hole. - -- - -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. - -- See 'NotInScopeError' for other not-in-scope errors. - -- - -- Test cases: T9177a. - = OutOfScopeHole [ImportError] - -- | Report a typed hole, or wildcard, with additional information. - | HoleError HoleSort - [TcTyVar] -- Other type variables which get computed on the way. - [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. - --- | A message that aims to explain why two types couldn't be seen --- to be representationally equal. -data CoercibleMsg - -- | Not knowing the role of a type constructor prevents us from - -- concluding that two types are representationally equal. - -- - -- Example: - -- - -- foo :: Applicative m => m (Sum Int) - -- foo = coerce (pure $ 1 :: Int) - -- - -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. - -- - -- Test cases: T8984, TcCoercibleFail. - = UnknownRoles Type - - -- | The fact that a 'TyCon' is abstract prevents us from decomposing - -- a 'TyConApp' and deducing that two types are representationally equal. - -- - -- Test cases: none. - | TyConIsAbstract TyCon - - -- | We can't unwrap a newtype whose constructor is not in scope. - -- - -- Example: - -- - -- import Data.Ord (Down) -- NB: not importing the constructor - -- foo :: Int -> Down Int - -- foo = coerce - -- - -- Test cases: TcCoercibleFail. - | OutOfScopeNewtypeConstructor TyCon DataCon - --- | Explain a problem with an import. -data ImportError - -- | Couldn't find a module with the requested name. - = MissingModule ModuleName - -- | The imported modules don't export what we're looking for. - | ModulesDoNotExport (NE.NonEmpty Module) OccName - --- | This datatype collates instances that match or unifier, --- in order to report an error message for an unsolved typeclass constraint. -data PotentialInstances - = PotentialInstances - { matches :: [ClsInst] - , unifiers :: [ClsInst] - } - --- | Append additional information to a `TcSolverReportMsg`. -mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg -mkTcReportWithInfo msg [] - = msg -mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos - = TcReportWithInfo msg (prev NE.:| prevs ++ infos) -mkTcReportWithInfo msg (info : infos) - = TcReportWithInfo msg (info NE.:| infos) - --- | A collection of valid hole fits or refinement fits, --- in which some fits might have been suppressed. -data FitsMbSuppressed - = Fits - { fits :: [HoleFit] - , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. - } - --- | A collection of hole fits and refinement fits. -data ValidHoleFits - = ValidHoleFits - { holeFits :: FitsMbSuppressed - , refinementFits :: FitsMbSuppressed - } - -noValidHoleFits :: ValidHoleFits -noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) - -data RelevantBindings - = RelevantBindings - { relevantBindingNamesAndTys :: [(Name, Type)] - , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. - } - --- | Display some relevant bindings. -pprRelevantBindings :: RelevantBindings -> SDoc --- This function should be in "GHC.Tc.Errors.Ppr", --- but's it's here for the moment as it's needed in "GHC.Tc.Errors". -pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = - ppUnless (null bds) $ - hang (text "Relevant bindings include") - 2 (vcat (map ppr_binding bds) $$ ppWhen ran_out_of_fuel discardMsg) - where - ppr_binding (nm, tidy_ty) = - sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc nm)))] - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - --- | Stores the information to be reported in a representation-polymorphism --- error message. -data FixedRuntimeRepErrorInfo - = FRR_Info - { frr_info_origin :: FixedRuntimeRepOrigin - -- ^ What is the original type we checked for - -- representation-polymorphism, and what specific - -- check did we perform? - , frr_info_not_concrete :: Maybe (TcTyVar, TcType) - -- ^ Which non-concrete type did we try to - -- unify this concrete type variable with? - } - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (LocatedN RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (LocatedN RdrName) - | TySynCtx (LocatedN RdrName) - | TyFamilyCtx (LocatedN RdrName) - | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [LocatedN Name] - | ClassDeclCtx (LocatedN RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | HsTypePatCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module GHC.Tc.Errors.Types ( + -- * Main types + TcRnMessage(..) + , mkTcRnUnknownMessage + , TcRnMessageDetailed(..) + , TypeDataForbids(..) + , ErrInfo(..) + , FixedRuntimeRepProvenance(..) + , pprFixedRuntimeRepProvenance + , ShadowedNameProvenance(..) + , RecordFieldPart(..) + , IllegalNewtypeReason(..) + , InjectivityErrReason(..) + , HasKinds(..) + , hasKinds + , SuggestUndecidableInstances(..) + , suggestUndecidableInstances + , SuggestUnliftedTypes(..) + , DataSort(..), ppDataSort + , AllowedDataResKind(..) + , NotClosedReason(..) + , SuggestPartialTypeSignatures(..) + , suggestPartialTypeSignatures + , DeriveInstanceErrReason(..) + , UsingGeneralizedNewtypeDeriving(..) + , usingGeneralizedNewtypeDeriving + , DeriveAnyClassEnabled(..) + , deriveAnyClassEnabled + , DeriveInstanceBadConstructor(..) + , HasWildcard(..) + , hasWildcard + , BadAnonWildcardContext(..) + , SoleExtraConstraintWildcardAllowed(..) + , DeriveGenericsErrReason(..) + , HasAssociatedDataFamInsts(..) + , hasAssociatedDataFamInsts + , AssociatedTyLastVarInKind(..) + , associatedTyLastVarInKind + , AssociatedTyNotParamOverLastTyVar(..) + , associatedTyNotParamOverLastTyVar + , MissingSignature(..) + , Exported(..) + , HsDocContext(..) + , FixedRuntimeRepErrorInfo(..) + + , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc + + , SolverReport(..), SolverReportSupplementary(..) + , SolverReportWithCtxt(..) + , SolverReportErrCtxt(..) + , getUserGivens, discardProvCtxtGivens + , TcSolverReportMsg(..) + , CannotUnifyVariableReason(..) + , MismatchMsg(..) + , MismatchEA(..) + , mkPlainMismatchMsg, mkBasicMismatchMsg + , WhenMatching(..) + , ExpectedActualInfo(..) + , TyVarInfo(..), SameOccInfo(..) + , AmbiguityInfo(..) + , CND_Extra(..) + , FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits + , HoleFitDispConfig(..) + , RelevantBindings(..), pprRelevantBindings + , PromotionErr(..), pprPECategory, peCategory + , NotInScopeError(..), mkTcRnNotInScope + , ImportError(..) + , HoleError(..) + , CoercibleMsg(..) + , PotentialInstances(..) + , UnsupportedCallConvention(..) + , ExpectedBackends + , ArgOrResult(..) + , MatchArgsContext(..), MatchArgBadMatches(..) + , ConversionFailReason(..) + , UnrepresentableTypeDescr(..) + , LookupTHInstNameErrReason(..) + , SplicePhase(..) + , THDeclDescriptor(..) + , RunSpliceFailReason(..) + , ThingBeingConverted(..) + , IllegalDecls(..) + , EmptyStatementGroupErrReason(..) + , UnexpectedStatement(..) + ) where + +import GHC.Prelude + +import GHC.Hs +import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo, TcTyThing) +import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit) +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence (EvBindsVar) +import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) + , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing + , FixedRuntimeRepOrigin(..) ) +import GHC.Tc.Types.Rank (Rank) +import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType) +import GHC.Types.Error +import GHC.Types.Hint (UntickedPromotedThing(..)) +import GHC.Types.ForeignCall (CLabelString) +import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) +import qualified GHC.Types.Name.Occurrence as OccName +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Types.TyThing (TyThing) +import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar) +import GHC.Types.Var.Env (TidyEnv) +import GHC.Types.Var.Set (TyVarSet, VarSet) +import GHC.Unit.Types (Module) +import GHC.Utils.Outputable +import GHC.Core.Class (Class, ClassMinimalDef) +import GHC.Core.Coercion.Axiom (CoAxBranch) +import GHC.Core.ConLike (ConLike) +import GHC.Core.DataCon (DataCon) +import GHC.Core.FamInstEnv (FamInst) +import GHC.Core.InstEnv (ClsInst) +import GHC.Core.PatSyn (PatSyn) +import GHC.Core.Predicate (EqRel, predTypeEqRel) +import GHC.Core.TyCon (TyCon, TyConFlavour) +import GHC.Core.Type (Kind, Type, ThetaType, PredType) +import GHC.Driver.Backend (Backend) +import GHC.Unit.State (UnitState) +import GHC.Types.Basic +import GHC.Utils.Misc (capitalise, filterOut) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString (FastString) +import GHC.Exception.Type (SomeException) + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.List.NonEmpty as NE +import Data.Typeable (Typeable) +import GHC.Unit.Module.Warnings (WarningTxt) +import qualified Language.Haskell.TH.Syntax as TH + +import GHC.Generics ( Generic ) + +{- +Note [Migrating TcM Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As part of #18516, we are slowly migrating the diagnostic messages emitted +and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted +some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions +that accepted 3 SDocs an input: one for the important part of the message, +one for the context and one for any supplementary information. Consider the following: + + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: x4 + In a stmt of a 'do' block: return (x2, x4) + In the expression: + +Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" +as the important part, "In the expression" as the context and "In a stmt..In the expression" +as the supplementary, with the context and supplementary usually smashed together so that +the final message would be composed only by two SDoc (which would then be bulleted like in +the example). + +In order for us to smooth out the migration to the new diagnostic infrastructure, we +introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose +of bridging the two worlds together without breaking the external API or the existing +format of messages reported by GHC. + +Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden +diagnostic API inside Tc.Utils.Monad, enabling further refactorings. + +In the future, once the conversion will be complete and we will successfully eradicate +any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and +existence of these two types, which for now remain a "necessary evil". + +-} + +-- The majority of TcRn messages come with extra context about the error, +-- and this newtype captures it. See Note [Migrating TcM Messages]. +data ErrInfo = ErrInfo { + errInfoContext :: !SDoc + -- ^ Extra context associated to the error. + , errInfoSupplementary :: !SDoc + -- ^ Extra supplementary info associated to the error. + } + + +-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside +-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing +-- any extra info needed to correctly pretty-print this diagnostic later on. +data TcRnMessageDetailed + = TcRnMessageDetailed !ErrInfo + -- ^ Extra info associated with the message + !TcRnMessage + deriving Generic + +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) + => a -> TcRnMessage +mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag) + +-- | An error which might arise during typechecking/renaming. +data TcRnMessage where + {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins + to provide custom diagnostic messages originated during typechecking/renaming. + -} + TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage + + {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed + to be provided in order to qualify a diagnostic and where it was originated (and why). + It carries an extra 'UnitState' which can be used to pretty-print some names + and it wraps a 'TcRnMessageDetailed', which includes any extra context associated + with this diagnostic. + -} + TcRnMessageWithInfo :: !UnitState + -- ^ The 'UnitState' will allow us to pretty-print + -- some diagnostics with more detail. + -> !TcRnMessageDetailed + -> TcRnMessage + + {-| TcRnWithHsDocContext annotates an error message with the context in which + it originated. + -} + TcRnWithHsDocContext :: !HsDocContext + -> !TcRnMessage + -> TcRnMessage + + {-| TcRnSolverReport is the constructor used to report unsolved constraints + after constraint solving, as well as other errors such as hole fit errors. + + See the documentation of the 'TcSolverReportMsg' datatype for an overview + of the different errors. + -} + TcRnSolverReport :: SolverReportWithCtxt + -> DiagnosticReason + -> [GhcHint] + -> TcRnMessage + -- TODO: split up TcRnSolverReport into several components, + -- so that we can compute the reason and hints, as opposed + -- to having to pass them here. + + {-| TcRnRedundantConstraints is a warning that is emitted when a binding + has a user-written type signature which contains superfluous constraints. + + Example: + + f :: (Eq a, Ord a) => a -> a -> a + f x y = (x < y) || x == y + -- `Eq a` is superfluous: the `Ord a` constraint suffices. + + Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. + -} + TcRnRedundantConstraints :: [Id] + -> (SkolemInfoAnon, Bool) + -- ^ The contextual skolem info. + -- The boolean controls whether we + -- want to show it in the user message. + -- (Nice to keep track of the info in either case, + -- for other users of the GHC API.) + -> TcRnMessage + + {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern + match is inaccessible, because the constraint solver has detected a contradiction. + + Example: + + data B a where { MkTrue :: B True; MkFalse :: B False } + + foo :: B False -> Bool + foo MkFalse = False + foo MkTrue = True -- Inaccessible: requires True ~ False + + Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. + -} + TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. + -> SolverReportWithCtxt -- ^ The contradiction. + -> TcRnMessage + + {-| A type which was expected to have a fixed runtime representation + does not have a fixed runtime representation. + + Example: + + data D (a :: TYPE r) = MkD a + + Test cases: T11724, T18534, + RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype, + RepPolyPatSynRes, T20423 + -} + TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type + -> !FixedRuntimeRepProvenance + -> !ErrInfo -- Extra info accumulated in the TcM monad + -> TcRnMessage + + {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when + a Template Haskell quote implicitly uses 'lift'. + + Example: + warning1 :: Lift t => t -> Q Exp + warning1 x = [| x |] + + Test cases: th/T17804 + -} + TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage + {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) + that occurs if a pattern binding binds no variables at all, unless it is a + lone wild-card pattern, or a banged pattern. + + Example: + Just _ = rhs3 -- Warning: unused pattern binding + (_, _) = rhs4 -- Warning: unused pattern binding + _ = rhs3 -- No warning: lone wild-card pattern + !() = rhs4 -- No warning: banged pattern; behaves like seq + + Test cases: rename/{T13646,T17c,T17e,T7085} + -} + TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage + {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when + a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported + abstractly, i.e. 'T'. + + Test cases: rename/should_compile/T7167 + -} + TcRnDodgyImports :: RdrName -> TcRnMessage + {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype + 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a + type/data family. + + Example: + module Foo ( + T(..) -- Warning: T is a type synonym + , A(..) -- Warning: A is a type family + , C(..) -- Warning: C is a data family + ) where + + type T = Int + type family A :: * -> * + data family C :: * -> * + + Test cases: warnings/should_compile/DodgyExports01 + -} + TcRnDodgyExports :: Name -> TcRnMessage + {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when + an import declaration does not explicitly list all the names brought into scope. + + Test cases: rename/should_compile/T4489 + -} + TcRnMissingImportList :: IE GhcPs -> TcRnMessage + {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled + with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the + reason the module was inferred to be unsafe. This warning is not raised if the + -fplugin-trustworthy flag is passed. + + Test cases: plugins/T19926 + -} + TcRnUnsafeDueToPlugin :: TcRnMessage + {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks + an associated 'RealSrcSpan'. + + Test cases: None + -} + TcRnModMissingRealSrcSpan :: Module -> TcRnMessage + {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs + when an identifier required by a signature is not exported by the module + or signature that is being used as a substitution for that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail36 + -} + TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage + {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that + occurs when an identifier which is necessary for implementing a module + signature is not exported from that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail30 + backpack/should_fail/bkpfail31 + backpack/should_fail/bkpfail34 + -} + TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage + + {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever + an inner-scope value has the same name as an outer-scope value, i.e. the inner + value shadows the outer one. This can catch typographical errors that turn into + hard-to-find bugs. The warning is suppressed for names beginning with an underscore. + + Examples(s): + f = ... let f = id in ... f ... -- NOT OK, 'f' is shadowed + f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore + + Test cases: typecheck/should_compile/T10971a + rename/should_compile/rn039 + rename/should_compile/rn064 + rename/should_compile/T1972 + rename/should_fail/T2723 + rename/should_compile/T3262 + driver/werror + -} + TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage + + {-| TcRnDuplicateWarningDecls is an error that occurs whenever + a warning is declared twice. + + Examples(s): + None. + + Test cases: + None. + -} + TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage + + {-| TcRnDuplicateWarningDecls is an error that occurs whenever + the constraint solver in the simplifier hits the iterations' limit. + + Examples(s): + None. + + Test cases: + None. + -} + TcRnSimplifierTooManyIterations :: Cts + -> !IntWithInf + -- ^ The limit. + -> WantedConstraints + -> TcRnMessage + + {-| TcRnIllegalPatSynDecl is an error that occurs whenever + there is an illegal pattern synonym declaration. + + Examples(s): + + varWithLocalPatSyn x = case x of + P -> () + where + pattern P = () -- not valid, it can't be local, it must be defined at top-level. + + Test cases: patsyn/should_fail/local + -} + TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage + + {-| TcRnLinearPatSyn is an error that occurs whenever a pattern + synonym signature uses a field that is not unrestricted. + + Example(s): None + + Test cases: linear/should_fail/LinearPatSyn2 + -} + TcRnLinearPatSyn :: !Type -> TcRnMessage + + {-| TcRnEmptyRecordUpdate is an error that occurs whenever + a record is updated without specifying any field. + + Examples(s): + + $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions + + Test cases: th/T12788 + -} + TcRnEmptyRecordUpdate :: TcRnMessage + + {-| TcRnIllegalFieldPunning is an error that occurs whenever + field punning is used without the 'NamedFieldPuns' extension enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{a} = a -- Not ok, punning used without extension. + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage + + {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever + wildcards (..) are used in a record without the relevant + extension being enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{..} = a -- Not ok, wildcards used without extension. + + Test cases: parser/should_fail/RecordWildCardsFail + -} + TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage + + {-| TcRnIllegalWildcardInType is an error that occurs + when a wildcard appears in a type in a location in which + wildcards aren't allowed. + + Examples: + + Type synonyms: + + type T = _ + + Class declarations and instances: + + class C _ + instance C _ + + Standalone kind signatures: + + type D :: _ + data D + + Test cases: + ExtraConstraintsWildcardInTypeSplice2 + ExtraConstraintsWildcardInTypeSpliceUsed + ExtraConstraintsWildcardNotLast + ExtraConstraintsWildcardTwice + NestedExtraConstraintsWildcard + NestedNamedExtraConstraintsWildcard + PartialClassMethodSignature + PartialClassMethodSignature2 + T12039 + T13324_fail1 + UnnamedConstraintWildcard1 + UnnamedConstraintWildcard2 + WildcardInADT1 + WildcardInADT2 + WildcardInADT3 + WildcardInADTContext1 + WildcardInDefault + WildcardInDefaultSignature + WildcardInDeriving + WildcardInForeignExport + WildcardInForeignImport + WildcardInGADT1 + WildcardInGADT2 + WildcardInInstanceHead + WildcardInInstanceSig + WildcardInNewtype + WildcardInPatSynSig + WildcardInStandaloneDeriving + WildcardInTypeFamilyInstanceRHS + WildcardInTypeSynonymRHS + saks_fail003 + T15433a + -} + + TcRnIllegalWildcardInType + :: Maybe Name + -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard + -> !BadAnonWildcardContext + -> TcRnMessage + + + {-| TcRnDuplicateFieldName is an error that occurs whenever + there are duplicate field names in a record. + + Examples(s): None. + + Test cases: None. + -} + TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage + + {-| TcRnIllegalViewPattern is an error that occurs whenever + the ViewPatterns syntax is used but the ViewPatterns language extension + is not enabled. + + Examples(s): + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled. + + Test cases: parser/should_fail/ViewPatternsFail + -} + TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage + + {-| TcRnCharLiteralOutOfRange is an error that occurs whenever + a character is out of range. + + Examples(s): None + + Test cases: None + -} + TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage + + {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever + the record wildcards '..' are used inside a constructor without labeled fields. + + Examples(s): None + + Test cases: None + -} + TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage + + {-| TcRnIgnoringAnnotations is a warning that occurs when the source code + contains annotation pragmas but the platform in use does not support an + external interpreter such as GHCi and therefore the annotations are ignored. + + Example(s): None + + Test cases: None + -} + TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage + + {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas + are used in conjunction with Safe Haskell. + + Example(s): None + + Test cases: annotations/should_fail/T10826 + -} + TcRnAnnotationInSafeHaskell :: TcRnMessage + + {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application + is used with an expression that does not accept "specified" type arguments. + + Example(s): + foo :: forall {a}. a -> a + foo x = x + bar :: () + bar = let x = foo @Int 42 + in () + + Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 + typecheck/should_fail/ExplicitSpecificity1 + typecheck/should_fail/ExplicitSpecificity10 + typecheck/should_fail/ExplicitSpecificity2 + typecheck/should_fail/T17173 + typecheck/should_fail/VtaFail + -} + TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage + + {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' + function is not applied to a single value argument. + + Example(s): + tagToEnum# 1 2 + + Test cases: None + -} + TcRnTagToEnumMissingValArg :: TcRnMessage + + {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' + function is not given a concrete result type. + + Example(s): + foo :: forall a. a + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' + function is given a result type that is not an enumeration type. + + Example(s): + foo :: Int -- not an enumeration TyCon + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#' + function is given a result type that is headed by a @type data@ type, as + the data constructors of a @type data@ do not exist at the term level. + + Example(s): + type data Letter = A | B | C + + foo :: Letter + foo = tagToEnum# 0# + + Test cases: type-data/should_fail/TDTagToEnum.hs + -} + TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage + + {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the + predicate type of an ifThenElse expression in arrow notation depends on + the type of the result. + + Example(s): None + + Test cases: None + -} + TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage + + {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file + contains declarations that are not allowed, such as bindings. + + Example(s): None + + Test cases: None + -} + TcRnIllegalHsBootFileDecl :: TcRnMessage + + {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym + is defined in terms of itself, either directly or indirectly. + + Example(s): + pattern A = B + pattern B = A + + Test cases: patsyn/should_fail/T16900 + -} + TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature + attempts to unify two different types. + + Example(s): + f :: a -> b -> _ + f x y = [x, y] + + Test cases: partial-sigs/should_fail/T14449 + -} + TcRnPartialTypeSigTyVarMismatch + :: Name -- ^ first type variable + -> Name -- ^ second type variable + -> Name -- ^ function name + -> LHsSigWcType GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable + being quantified over in the partial type signature of a function gets unified + with a type that is free in that function's context. + + Example(s): + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + Test cases: partial-sig/should_fail/T14479 + -} + TcRnPartialTypeSigBadQuantifier + :: Name -- ^ user-written name of type variable being quantified + -> Name -- ^ function name + -> Maybe Type -- ^ type the variable unified with, if known + -> LHsSigWcType GhcRn -- ^ partial type signature + -> TcRnMessage + + {-| TcRnMissingSignature is a warning that occurs when a top-level binding + or a pattern synonym does not have a type signature. + + Controlled by the flags: + -Wmissing-signatures + -Wmissing-exported-signatures + -Wmissing-pattern-synonym-signatures + -Wmissing-exported-pattern-synonym-signatures + -Wmissing-kind-signatures + + Test cases: + T11077 (top-level bindings) + T12484 (pattern synonyms) + T19564 (kind signatures) + -} + TcRnMissingSignature :: MissingSignature + -> Exported + -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures, + -- or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures + -> TcRnMessage + + {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures + that occurs when a local polymorphic binding lacks a type signature. + + Example(s): + id a = a + + Test cases: warnings/should_compile/T12574 + -} + TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage + + {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts + with the monomorphism restriction. + + Example(s): + data T a = T a + mono = ... where + x :: Applicative f => f a + T x = ... + + Test cases: typecheck/should_compile/T11339 + -} + TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage + + {-| TcRnTupleConstraintInst is an error that occurs whenever an instance + for a tuple constraint is specified. + + Examples(s): + class C m a + class D m a + f :: (forall a. Eq a => (C m a, D m a)) => m a + f = undefined + + Test cases: quantified-constraints/T15334 + -} + TcRnTupleConstraintInst :: !Class -> TcRnMessage + + {-| TcRnAbstractClassInst is an error that occurs whenever an instance + of an abstract class is specified. + + Examples(s): + -- A.hs-boot + module A where + class C a + + -- B.hs + module B where + import {-# SOURCE #-} A + instance C Int where + + -- A.hs + module A where + import B + class C a where + f :: a + + -- Main.hs + import A + main = print (f :: Int) + + Test cases: typecheck/should_fail/T13068 + -} + TcRnAbstractClassInst :: !Class -> TcRnMessage + + {-| TcRnNoClassInstHead is an error that occurs whenever an instance + head is not headed by a class. + + Examples(s): + instance c + + Test cases: typecheck/rename/T5513 + typecheck/rename/T16385 + -} + TcRnNoClassInstHead :: !Type -> TcRnMessage + + {-| TcRnUserTypeError is an error that occurs due to a user's custom type error, + which can be triggered by adding a `TypeError` constraint in a type signature + or typeclass instance. + + Examples(s): + f :: TypeError (Text "This is a type error") + f = undefined + + Test cases: typecheck/should_fail/CustomTypeErrors02 + typecheck/should_fail/CustomTypeErrors03 + -} + TcRnUserTypeError :: !Type -> TcRnMessage + + {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified + in a kind. + + Examples(s): + data Q :: Eq a => Type where {} + + Test cases: dependent/should_fail/T13895 + polykinds/T16263 + saks/should_fail/saks_fail004 + typecheck/should_fail/T16059a + typecheck/should_fail/T18714 + -} + TcRnConstraintInKind :: !Type -> TcRnMessage + + {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple + or unboxed sum type is specified as a function argument, when the appropriate + extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled. + + Examples(s): + -- T15073.hs + import T15073a + newtype Foo a = MkFoo a + deriving P + + -- T15073a.hs + class P a where + p :: a -> (# a #) + + Test cases: deriving/should_fail/T15073.hs + deriving/should_fail/T15073a.hs + typecheck/should_fail/T16059d + -} + TcRnUnboxedTupleOrSumTypeFuncArg + :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum + -> !Type + -> TcRnMessage + + {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is + specified in a kind. + + Examples(s): + data A :: * %1 -> * + + Test cases: linear/should_fail/LinearKind + linear/should_fail/LinearKind2 + linear/should_fail/LinearKind3 + -} + TcRnLinearFuncInKind :: !Type -> TcRnMessage + + {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind + mentions quantified type variable. + + Examples(s): + type T :: TYPE (BoxedRep l) + data T = MkT + + Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly + -} + TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage + + {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification + is specified in the type of a term. + + Examples(s): + a = (undefined :: forall k -> k -> Type) @Int + + Test cases: dependent/should_fail/T15859 + dependent/should_fail/T16326_Fail1 + dependent/should_fail/T16326_Fail2 + dependent/should_fail/T16326_Fail3 + dependent/should_fail/T16326_Fail4 + dependent/should_fail/T16326_Fail5 + dependent/should_fail/T16326_Fail6 + dependent/should_fail/T16326_Fail7 + dependent/should_fail/T16326_Fail8 + dependent/should_fail/T16326_Fail9 + dependent/should_fail/T16326_Fail10 + dependent/should_fail/T16326_Fail11 + dependent/should_fail/T16326_Fail12 + dependent/should_fail/T17687 + dependent/should_fail/T18271 + -} + TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage + + {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate + lacks a class or type variable head. + + Examples(s): + class (forall a. A t a => A t [a]) => B t where + type A t a :: Constraint + + Test cases: quantified-constraints/T16474 + -} + TcRnBadQuantPredHead :: !Type -> TcRnMessage + + {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple + constraint is specified. + + Examples(s): + g :: ((Show a, Num a), Eq a) => a -> a + g = undefined + + Test cases: typecheck/should_fail/tcfail209a + -} + TcRnIllegalTupleConstraint :: !Type -> TcRnMessage + + {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable + argument is specified in a constraint. + + Examples(s): + data T + instance Eq Int => Eq T + + Test cases: ghci/scripts/T13202 + ghci/scripts/T13202a + polykinds/T12055a + typecheck/should_fail/T10351 + typecheck/should_fail/T19187 + typecheck/should_fail/T6022 + typecheck/should_fail/T8883 + -} + TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage + + {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit + parameter is specified. + + Examples(s): + type Bla = ?x::Int + data T = T + instance Bla => Eq T + + Test cases: polykinds/T11466 + typecheck/should_fail/T8912 + typecheck/should_fail/tcfail041 + typecheck/should_fail/tcfail211 + typecheck/should_fail/tcrun045 + -} + TcRnIllegalImplicitParam :: !Type -> TcRnMessage + + {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint + synonym of kind is specified. + + Examples(s): + type Showish = Show + f :: (Showish a) => a -> a + f = undefined + + Test cases: typecheck/should_fail/tcfail209 + -} + TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage + + {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified + for a non-class. + + Examples(s): + type C1 a = (Show (a -> Bool)) + instance C1 Int where + + Test cases: polykinds/T13267 + -} + TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage + + {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated + visible kind argument is specified. + + Examples(s): + type family + F2 :: forall (a :: Type). Type where + F2 @a = Maybe a + + Test cases: typecheck/should_fail/T15793 + typecheck/should_fail/T16255 + -} + TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage + + {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an + associated type. + + Examples(s): + $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo) + [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)] + return [d]) + ======> + instance Eq Foo where + type Rep Foo = Maybe + + Test cases: th/T12387a + -} + TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> TcRnMessage + + {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type + is specified. + + Examples(s): + foo :: (a,b) -> (a~b => t) -> (a,b) + foo p x = p + + Test cases: + - ghci/should_run/T15806 + - indexed-types/should_fail/SimpleFail15 + - typecheck/should_fail/T11355 + - typecheck/should_fail/T12083a + - typecheck/should_fail/T12083b + - typecheck/should_fail/T16059c + - typecheck/should_fail/T16059e + - typecheck/should_fail/T17213 + - typecheck/should_fail/T18939_Fail + - typecheck/should_fail/T2538 + - typecheck/should_fail/T5957 + - typecheck/should_fail/T7019 + - typecheck/should_fail/T7019a + - typecheck/should_fail/T7809 + - typecheck/should_fail/T9196 + - typecheck/should_fail/tcfail127 + - typecheck/should_fail/tcfail184 + - typecheck/should_fail/tcfail196 + - typecheck/should_fail/tcfail197 + -} + TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage + + {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) + that arise when the monomorphism restriction applies to the given bindings. + + Examples(s): + {-# OPTIONS_GHC -Wmonomorphism-restriction #-} + + bar = 10 + + foo :: Int + foo = bar + + main :: IO () + main = print foo + + The example above emits the warning (for 'bar'), because without monomorphism + restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us + that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar' + less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that. + + Test cases: typecheck/should_compile/T13785 + -} + TcRnMonomorphicBindings :: [Name] -> TcRnMessage + + {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans) + that arises when a typeclass instance is an \"orphan\", i.e. if it appears + in a module in which neither the class nor the type being instanced are + declared in the same module. + + Examples(s): None + + Test cases: warnings/should_compile/T9178 + typecheck/should_compile/T4912 + -} + TcRnOrphanInstance :: ClsInst -> TcRnMessage + + {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies + conflicts between instance declarations. + + Examples(s): None + + Test cases: typecheck/should_fail/T2307 + typecheck/should_fail/tcfail096 + typecheck/should_fail/tcfail202 + -} + TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance + declarations. + + Examples(s): + class Foo a where + foo :: a -> Int + + instance Foo Int where + foo = id + + instance Foo Int where + foo = const 42 + + Test cases: cabal/T12733/T12733 + typecheck/should_fail/tcfail035 + typecheck/should_fail/tcfail023 + backpack/should_fail/bkpfail18 + typecheck/should_fail/TcNullaryTCFail + typecheck/should_fail/tcfail036 + typecheck/should_fail/tcfail073 + module/mod51 + module/mod52 + module/mod44 + -} + TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting + family instance declarations. + + Examples(s): None. + + Test cases: indexed-types/should_fail/ExplicitForAllFams4b + indexed-types/should_fail/NoGood + indexed-types/should_fail/Over + indexed-types/should_fail/OverDirectThisMod + indexed-types/should_fail/OverIndirectThisMod + indexed-types/should_fail/SimpleFail11a + indexed-types/should_fail/SimpleFail11b + indexed-types/should_fail/SimpleFail11c + indexed-types/should_fail/SimpleFail11d + indexed-types/should_fail/SimpleFail2a + indexed-types/should_fail/SimpleFail2b + indexed-types/should_fail/T13092/T13092 + indexed-types/should_fail/T13092c/T13092c + indexed-types/should_fail/T14179 + indexed-types/should_fail/T2334A + indexed-types/should_fail/T2677 + indexed-types/should_fail/T3330b + indexed-types/should_fail/T4246 + indexed-types/should_fail/T7102a + indexed-types/should_fail/T9371 + polykinds/T7524 + typecheck/should_fail/UnliftedNewtypesOverlap + -} + TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage + + TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage + + {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a strictness annotation is applied to an unlifted type. + + Example(s): + data T = MkT !Int# -- Strictness flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T20187a + typecheck/should_compile/T20187b + -} + TcRnBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a lazy annotation is applied to an unlifted type. + + Example(s): + data T = MkT ~Int# -- Lazy flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T21951a + typecheck/should_compile/T21951b + -} + TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has + more than one default declaration. + + Example: + default (Integer, Int) + default (Double, Float) -- 2nd default declaration not allowed + + Text cases: module/mod58 + -} + TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage + + {-| TcRnBadDefaultType is an error that occurs when a type used in a default + declaration does not have an instance for any of the applicable classes. + + Example(s): + data Foo + default (Foo) + + Test cases: typecheck/should_fail/T11974b + -} + TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage + + {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's + export list bundles a pattern synonym with a type that is not a proper + `data` or `newtype` construction. + + Example(s): + module Foo (MyClass(.., P)) where + pattern P = Nothing + class MyClass a where + foo :: a -> Int + + Test cases: patsyn/should_fail/export-class + -} + TcRnPatSynBundledWithNonDataCon :: TcRnMessage + + {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list + of a module has a pattern synonym bundled with a type that does not match + the type of the pattern synonym. + + Example(s): + module Foo (R(P,x)) where + data Q = Q Int + data R = R + pattern P{x} = Q x + + Text cases: patsyn/should_fail/export-ps-rec-sel + patsyn/should_fail/export-type-synonym + patsyn/should_fail/export-type + -} + TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage + + {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that + occurs when a module appears more than once in an export list. + + Example(s): + module Foo (module Bar, module Bar) + import Bar + + Text cases: None + -} + TcRnDupeModuleExport :: ModuleName -> TcRnMessage + + {-| TcRnExportedModNotImported is an error that occurs when an export list + contains a module that is not imported. + + Example(s): None + + Text cases: module/mod135 + module/mod8 + rename/should_fail/rnfail028 + backpack/should_fail/bkpfail48 + -} + TcRnExportedModNotImported :: ModuleName -> TcRnMessage + + {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs + when an export list contains a module that has no exports. + + Example(s): + module Foo (module Bar) where + import Bar () + + Test cases: None + -} + TcRnNullExportedModule :: ModuleName -> TcRnMessage + + {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that + occurs when a module does not have an explicit export list. + + Example(s): None + + Test cases: typecheck/should_fail/MissingExportList03 + -} + TcRnMissingExportList :: ModuleName -> TcRnMessage + + {-| TcRnExportHiddenComponents is an error that occurs when an export contains + constructor or class methods that are not visible. + + Example(s): None + + Test cases: None + -} + TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs + when an identifier appears in an export list more than once. + + Example(s): None + + Test cases: module/MultiExport + module/mod128 + module/mod14 + module/mod5 + overloadedrecflds/should_fail/DuplicateExports + patsyn/should_compile/T11959 + -} + TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnExportedParentChildMismatch is an error that occurs when an export is + bundled with a parent that it does not belong to + + Example(s): + module Foo (T(a)) where + data T + a = True + + Test cases: module/T11970 + module/T11970B + module/mod17 + module/mod3 + overloadedrecflds/should_fail/NoParent + -} + TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage + + {-| TcRnConflictingExports is an error that occurs when different identifiers that + have the same name are being exported by a module. + + Example(s): + module Foo (Bar.f, module Baz) where + import qualified Bar (f) + import Baz (f) + + Test cases: module/mod131 + module/mod142 + module/mod143 + module/mod144 + module/mod145 + module/mod146 + module/mod150 + module/mod155 + overloadedrecflds/should_fail/T14953 + overloadedrecflds/should_fail/overloadedrecfldsfail10 + rename/should_fail/rnfail029 + rename/should_fail/rnfail040 + typecheck/should_fail/T16453E2 + typecheck/should_fail/tcfail025 + typecheck/should_fail/tcfail026 + -} + TcRnConflictingExports + :: OccName -- ^ Occurrence name shared by both exports + -> GreName -- ^ Name of first export + -> GlobalRdrElt -- ^ Provenance for definition site of first export + -> IE GhcPs -- ^ Export decl of first export + -> GreName -- ^ Name of second export + -> GlobalRdrElt -- ^ Provenance for definition site of second export + -> IE GhcPs -- ^ Export decl of second export + -> TcRnMessage + + {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring + when a record update's type cannot be precisely determined. This will not + be supported by -XDuplicateRecordFields in future releases. + + Example(s): + data Person = MkPerson { personId :: Int, name :: String } + data Address = MkAddress { personId :: Int, address :: String } + bad1 x = x { personId = 4 } :: Person -- ambiguous + bad2 (x :: Person) = x { personId = 4 } -- ambiguous + good x = (x :: Person) { personId = 4 } -- not ambiguous + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 + -} + TcRnAmbiguousField + :: HsExpr GhcRn -- ^ Field update + -> TyCon -- ^ Record type + -> TcRnMessage + + {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring + when the intialisation of a record is missing one or more (lazy) fields. + + Example(s): + data Rec = Rec { a :: Int, b :: String, c :: Bool } + x = Rec { a = 1, b = "two" } -- missing field 'c' + + Test cases: deSugar/should_compile/T13870 + deSugar/should_compile/ds041 + patsyn/should_compile/T11283 + rename/should_compile/T5334 + rename/should_compile/T12229 + rename/should_compile/T5892a + warnings/should_fail/WerrorFail2 + -} + TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's + type mentions something that is outside the universally quantified variables + of the data constructor, such as an existentially quantified type. + + Example(s): + data X = forall a. MkX { f :: a } + x = (MkX ()) { f = False } + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3323 + -} + TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage + + {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update + has fields that no single constructor encompasses. + + Example(s): + data Foo = A { x :: Bool } + | B { y :: Int } + foo = (A False) { x = True, y = 5 } + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08 + patsyn/should_fail/mixed-pat-syn-record-sels + typecheck/should_fail/T7989 + -} + TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage + + {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and + record selectors are used in the same record update block. + + Example(s): + data Rec = Rec { foo :: Int, bar :: String } + pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 } + illegal :: Rec -> Rec + illegal r = r { f1 = 1, bar = "two" } + + Test cases: patsyn/should_fail/records-mixing-fields + -} + TcRnMixedSelectors + :: Name -- ^ Record + -> [Id] -- ^ Record selectors + -> Name -- ^ Pattern synonym + -> [Id] -- ^ Pattern selectors + -> TcRnMessage + + {- TcRnMissingStrictFields is an error occurring when a record field marked + as strict is omitted when constructing said record. + + Example(s): + data R = R { strictField :: !Bool, nonStrict :: Int } + x = R { nonStrict = 1 } + + Test cases: typecheck/should_fail/T18869 + typecheck/should_fail/tcfail085 + typecheck/should_fail/tcfail112 + -} + TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a + record update block do not all belong to any one type. + + Example(s): + data R1 = R1 { x :: Int, y :: Int } + data R2 = R2 { y :: Int, z :: Int } + update r = r { x = 1, y = 2, z = 3 } + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail14 + -} + TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage + + {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot + be pinned down to any one constructor and thus must be given a type signature. + + Example(s): + data R1 = R1 { x :: Int } + data R2 = R2 { x :: Int } + update r = r { x = 1 } -- needs a type signature + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + -} + TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage + + {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static + using the -XStaticPointers extension but which are not closed terms. + + Example(s): + f x = static x + + Test cases: rename/should_fail/RnStaticPointersFail01 + rename/should_fail/RnStaticPointersFail03 + -} + TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + {-| TcRnSpecialClassInst is an error that occurs when a user + attempts to define an instance for a built-in typeclass such as + 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file. + + Test cases: deriving/should_fail/T9687 + deriving/should_fail/T14916 + polykinds/T8132 + typecheck/should_fail/TcCoercibleFail2 + typecheck/should_fail/T12837 + typecheck/should_fail/T14390 + + -} + TcRnSpecialClassInst :: !Class + -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled + -> TcRnMessage + + {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that + occurs when trying to derive an instance of the 'Typeable' class. Deriving + 'Typeable' is no longer necessary (hence the \"useless\") as all types + automatically derive 'Typeable' in modern GHC versions. + + Example(s): None. + + Test cases: warnings/should_compile/DerivingTypeable + -} + TcRnUselessTypeable :: TcRnMessage + + {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that + occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not + be what the user wants. + + Example(s): None. + + Test cases: typecheck/should_compile/T15839a + deriving/should_compile/T16179 + -} + TcRnDerivingDefaults :: !Class -> TcRnMessage + + {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC + encounters a non-unary constraint when trying to derive a typeclass. + + Example(s): + class A + deriving instance A + data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). + + Test cases: deriving/should_fail/T7959 + deriving/should_fail/drvfail005 + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail006 + -} + TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage + + {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) + that occurs when a wildcard '_' is found in place of a type in a signature or a + type class derivation + + Example(s): + foo :: _ -> Int + foo = ... + + deriving instance _ => Eq (Foo a) + + Test cases: dependent/should_compile/T11241 + dependent/should_compile/T15076 + dependent/should_compile/T14880-2 + typecheck/should_compile/T17024 + typecheck/should_compile/T10072 + partial-sigs/should_fail/TidyClash2 + partial-sigs/should_fail/Defaulting1MROff + partial-sigs/should_fail/WildcardsInPatternAndExprSig + partial-sigs/should_fail/T10615 + partial-sigs/should_fail/T14584a + partial-sigs/should_fail/TidyClash + partial-sigs/should_fail/T11122 + partial-sigs/should_fail/T14584 + partial-sigs/should_fail/T10045 + partial-sigs/should_fail/PartialTypeSignaturesDisabled + partial-sigs/should_fail/T10999 + partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature + partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice + partial-sigs/should_fail/WildcardInstantiations + partial-sigs/should_run/T15415 + partial-sigs/should_compile/T10463 + partial-sigs/should_compile/T15039a + partial-sigs/should_compile/T16728b + partial-sigs/should_compile/T15039c + partial-sigs/should_compile/T10438 + partial-sigs/should_compile/SplicesUsed + partial-sigs/should_compile/T18008 + partial-sigs/should_compile/ExprSigLocal + partial-sigs/should_compile/T11339a + partial-sigs/should_compile/T11670 + partial-sigs/should_compile/WarningWildcardInstantiations + partial-sigs/should_compile/T16728 + partial-sigs/should_compile/T12033 + partial-sigs/should_compile/T15039b + partial-sigs/should_compile/T10403 + partial-sigs/should_compile/T11192 + partial-sigs/should_compile/T16728a + partial-sigs/should_compile/TypedSplice + partial-sigs/should_compile/T15039d + partial-sigs/should_compile/T11016 + partial-sigs/should_compile/T13324_compile2 + linear/should_fail/LinearPartialSig + polykinds/T14265 + polykinds/T14172 + -} + TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage + + {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance + can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason + this error arose. + + Example(s): None. + + Test cases: generics/T10604/T10604_no_PolyKinds + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail-functor2 + deriving/should_fail/T10598_fail3 + deriving/should_fail/deriving-via-fail2 + deriving/should_fail/deriving-via-fail + deriving/should_fail/T16181 + -} + TcRnCannotDeriveInstance :: !Class + -- ^ The typeclass we are trying to derive + -- an instance for + -> [Type] + -- ^ The typeclass arguments, if any. + -> !(Maybe (DerivStrategy GhcTc)) + -- ^ The derivation strategy, if any. + -> !UsingGeneralizedNewtypeDeriving + -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? + -> !DeriveInstanceErrReason + -- ^ The specific reason why we couldn't derive + -- an instance for the class. + -> TcRnMessage + + {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested + GADT pattern match inside a lazy (~) pattern. + + Test case: gadt/lazypat + -} + TcRnLazyGADTPattern :: TcRnMessage + + {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a + GADT pattern inside arrow proc notation. + + Test case: arrows/should_fail/arrowfail004. + -} + TcRnArrowProcGADTPattern :: TcRnMessage + + {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs + when a definition uses 'forall' as an identifier. + + Example: + forall x = () + g forall = () + + Test cases: T20609 T20609a T20609b T20609c T20609d + -} + TcRnForallIdentifier :: RdrName -> TcRnMessage + + {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope) + that occurs when the type equality (a ~ b) is not in scope. + + Test case: T18862b + -} + TcRnTypeEqualityOutOfScope :: TcRnMessage + + {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators) + that occurs when the type equality (a ~ b) is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: (a ~ b) => a -> b + + Test case: T18862a + -} + TcRnTypeEqualityRequiresOperators :: TcRnMessage + + {-| TcRnIllegalTypeOperator is an error that occurs when a type operator + is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: Vec a n -> Vec a m -> Vec a (n + m) + + Test case: T12811 + -} + TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage + + {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class + operator is declared without the TypeOperators extension. + + See Note [Type and class operator definitions] + + Example: + {-# LANGUAGE Haskell2010 #-} + {-# LANGUAGE MultiParamTypeClasses #-} + + module T3265 where + + data a :+: b = Left a | Right b + + class a :*: b where {} + + + Test cases: T3265, tcfail173 + -} + TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage + + + {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds + that occurs when pattern matching on a GADT when -XMonoLocalBinds is off. + + Example(s): None + + Test cases: T20485, T20485a + -} + TcRnGADTMonoLocalBinds :: TcRnMessage + {-| The TcRnNotInScope constructor is used for various not-in-scope errors. + See 'NotInScopeError' for more details. -} + TcRnNotInScope :: NotInScopeError -- ^ what the problem is + -> RdrName -- ^ the name that is not in scope + -> [ImportError] -- ^ import errors that are relevant + -> [GhcHint] -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor + -> TcRnMessage + + {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors) + that is triggered by an unticked occurrence of a promoted data constructor. + + Examples: + + data A = MkA + type family F (a :: A) where { F MkA = Bool } + + type B = [ Int, Bool ] + + Test cases: T9778, T19984. + -} + TcRnUntickedPromotedThing :: UntickedPromotedThing + -> TcRnMessage + + {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears + in an unexpected location, e.g. as a data constructor or in a fixity declaration. + + Examples: + + infixl 5 : + + data P = (,) + + Test cases: rnfail042, T14907b, T15124, T15233. + -} + TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...) + -> RdrName + -> TcRnMessage + -- TODO: remove the SDoc argument. + + {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) + that is triggered whenever a Wanted typeclass constraint + is solving through the defaulting of a type variable. + + Example: + + one = show 1 + -- We get Wanteds Show a0, Num a0, and default a0 to Integer. + + Test cases: + none (which are really specific to defaulting), + but see e.g. tcfail204. + -} + TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred + -> Maybe TyVar -- ^ The type variable being defaulted + -> Type -- ^ The default type + -> TcRnMessage + + {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' + is used in the incorrect 'NameSpace', e.g. a type constructor + or class used in a term, or a term variable used in a type. + + Example: + + f x = Int + + Test cases: T18740a, T20884. + -} + TcRnIncorrectNameSpace :: Name + -> Bool -- ^ whether the error is happening + -- in a Template Haskell tick + -- (so we should give a Template Haskell hint) + -> TcRnMessage + + {- TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import + is declared using the @prim@ calling convention without having turned on + the -XGHCForeignImportPrim extension. + + Example(s): + foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) + + Test cases: ffi/should_fail/T20116 + -} + TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage + + {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe + annotation should not be used with @prim@ foreign imports. + + Example(s): + foreign import prim unsafe "my_primop_cmm" :: ... + + Test cases: None + -} + TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage + + {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ + imports cannot have function types. + + Example(s): + foreign import capi "math.h value sqrt" f :: CInt -> CInt + + Test cases: ffi/should_fail/capi_value_function + -} + TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage + + {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ + that informs the user of a possible missing @&@ in the declaration of a + foreign import with a 'FunPtr' return type. + + Example(s): + foreign import ccall "f" f :: FunPtr (Int -> IO ()) + + Test cases: ffi/should_compile/T1357 + -} + TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage + + {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration + is not compatible with the code generation backend being used. + + Example(s): None + + Test cases: None + -} + TcRnIllegalForeignDeclBackend + :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> Backend + -> ExpectedBackends + -> TcRnMessage + + {- TcRnUnsupportedCallConv informs the user that the calling convention specified + for a foreign export declaration is not compatible with the target platform. + It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of + @stdcall@ but is otherwise considered an error. + + Example(s): None + + Test cases: None + -} + TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> UnsupportedCallConvention + -> TcRnMessage + + {- TcRnIllegalForeignType is an error for when a type appears in a foreign + function signature that is not compatible with the FFI. + + Example(s): None + + Test cases: ffi/should_fail/T3066 + ffi/should_fail/ccfail004 + ffi/should_fail/T10461 + ffi/should_fail/T7506 + ffi/should_fail/T5664 + safeHaskell/ghci/p6 + safeHaskell/safeLanguage/SafeLang08 + ffi/should_fail/T16702 + linear/should_fail/LinearFFI + ffi/should_fail/T7243 + -} + TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage + + {- TcRnInvalidCIdentifier indicates a C identifier that is not valid. + + Example(s): + foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# + + Test cases: th/T10638 + -} + TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage + + {- TcRnExpectedValueId is an error occurring when something that is not a + value identifier is used where one is expected. + + Example(s): none + + Test cases: none + -} + TcRnExpectedValueId :: !TcTyThing -> TcRnMessage + + {- TcRnNotARecordSelector is an error for when something that is not a record + selector is used in a record pattern. + + Example(s): + data Rec = MkRec { field :: Int } + r = Mkrec 1 + r' = r { notAField = 2 } + + Test cases: rename/should_fail/rnfail054 + typecheck/should_fail/tcfail114 + -} + TcRnNotARecordSelector :: !Name -> TcRnMessage + + {- TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector + containing an existential type variable is used as a function rather than in + a pattern match. + + Example(s): + data Rec = forall a. Rec { field :: a } + field (Rec True) + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3176 + -} + TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage + + {- TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern + synonym is used as a constructor. + + Example(s): + pattern Five :: Int + pattern Five <- 5 + five = Five + + Test cases: patsyn/should_fail/records-no-uni-update + patsyn/should_fail/records-no-uni-update2 + -} + TcRnPatSynNotBidirectional :: !Name -> TcRnMessage + + {- TcRnSplicePolymorphicLocalVar is the error that occurs when the expression + inside typed template haskell brackets is a polymorphic local variable. + + Example(s): + x = \(y :: forall a. a -> a) -> [|| y ||] + + Test cases: quotes/T10384 + -} + TcRnSplicePolymorphicLocalVar :: !Id -> TcRnMessage + + {- TcRnIllegalDerivingItem is an error for when something other than a type class + appears in a deriving statement. + + Example(s): + data X = X deriving Int + + Test cases: deriving/should_fail/T5922 + -} + TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage + + {- TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such + as strictness, laziness, or unpacking. + + Example(s): + data T = T { t :: Maybe {-# UNPACK #-} Int } + data C = C { f :: !IntMap Int } + + Test cases: parser/should_fail/unpack_inside_type + typecheck/should_fail/T7210 + -} + TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsSrcBang -> TcRnMessage + + {- TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax. + + Example(s): + data T = T Int { field :: Int } + + Test cases: rename/should_fail/T7943 + rename/should_fail/T9077 + -} + TcRnIllegalRecordSyntax :: !(HsType GhcRn) -> TcRnMessage + + {- TcRnUnexpectedTypeSplice is an error for a typed template haskell splice + appearing unexpectedly. + + Example(s): none + + Test cases: none + -} + TcRnUnexpectedTypeSplice :: !(HsType GhcRn) -> TcRnMessage + + {- TcRnInvalidVisibleKindArgument is an error for a kind application on a + target type that cannot accept it. + + Example(s): + bad :: Int @Type + bad = 1 + type Foo :: forall a {b}. a -> b -> b + type Foo x y = y + type Bar = Foo @Bool @Int True 42 + + Test cases: indexed-types/should_fail/T16356_Fail3 + typecheck/should_fail/ExplicitSpecificity7 + typecheck/should_fail/T12045b + typecheck/should_fail/T12045c + typecheck/should_fail/T15592a + typecheck/should_fail/T15816 + -} + TcRnInvalidVisibleKindArgument + :: !(LHsType GhcRn) -- ^ The visible kind argument + -> !Type -- ^ Target of the kind application + -> TcRnMessage + + {- TcRnTooManyBinders is an error for a type constructor that is declared with + more arguments then its kind specifies. + + Example(s): + type T :: Type -> (Type -> Type) -> Type + data T a (b :: Type -> Type) x1 (x2 :: Type -> Type) + + Test cases: saks/should_fail/saks_fail008 + -} + TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr () GhcRn] -> TcRnMessage + + {- TcRnDifferentNamesForTyVar is an error that indicates different names being + used for the same type variable. + + Example(s): + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + + Test cases: polykinds/T11203 + polykinds/T11821a + saks/should_fail/T20916 + typecheck/should_fail/T17566b + typecheck/should_fail/T17566c + -} + TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage + + {- TcRnInvalidReturnKind is an error for a data declaration that has a kind signature + with an invalid result kind. + + Example(s): + data family Foo :: Constraint + + Test cases: typecheck/should_fail/T14048b + typecheck/should_fail/UnliftedNewtypesConstraintFamily + typecheck/should_fail/T12729 + typecheck/should_fail/T15883 + typecheck/should_fail/T16829a + typecheck/should_fail/T16829b + typecheck/should_fail/UnliftedNewtypesNotEnabled + typecheck/should_fail/tcfail079 + -} + TcRnInvalidReturnKind + :: !DataSort -- ^ classification of thing being returned + -> !AllowedDataResKind -- ^ allowed kind + -> !Kind -- ^ the return kind + -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension + -> TcRnMessage + + {- TcRnClassKindNotConstraint is an error for a type class that has a kind that + is not equivalent to Constraint. + + Example(s): + type C :: Type -> Type + class C a + + Test cases: saks/should_fail/T16826 + -} + TcRnClassKindNotConstraint :: !Kind -> TcRnMessage + + {- TcRnUnpromotableThing is an error that occurs when the user attempts to + use the promoted version of something which is not promotable. + + Example(s): + data T :: T -> * + data X a where + MkX :: Show a => a -> X a + foo :: Proxy ('MkX 'True) + foo = Proxy + + Test cases: dependent/should_fail/PromotedClass + dependent/should_fail/T14845_fail1 + dependent/should_fail/T14845_fail2 + dependent/should_fail/T15215 + dependent/should_fail/T13780c + dependent/should_fail/T15245 + polykinds/T5716 + polykinds/T5716a + polykinds/T6129 + polykinds/T7433 + patsyn/should_fail/T11265 + patsyn/should_fail/T9161-1 + patsyn/should_fail/T9161-2 + dependent/should_fail/SelfDep + polykinds/PolyKinds06 + polykinds/PolyKinds07 + polykinds/T13625 + polykinds/T15116 + polykinds/T15116a + saks/should_fail/T16727a + saks/should_fail/T16727b + rename/should_fail/T12686 + -} + TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage + + {- TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches + that have different numbers of arguments + + Example(s): + foo x = True + foo x y = False + + Test cases: rename/should_fail/rnfail045 + typecheck/should_fail/T20768_fail + -} + TcRnMatchesHaveDiffNumArgs + :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics + -> !MatchArgBadMatches + -> TcRnMessage + + {- TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type + variables cannot be used in pattern bindings. + + Example(s): + let (x :: a) = 5 + + Test cases: typecheck/should_compile/tc141 + -} + TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {- TcRnCannotBindTyVarsInPatBind is an error for when type + variables are introduced in a pattern binding + + Example(s): + Just @a x = Just True + + Test cases: typecheck/should_fail/TyAppPat_PatternBinding + typecheck/should_fail/TyAppPat_PatternBindingExistential + -} + TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {- TcRnTooManyTyArgsInConPattern is an error occurring when a constructor pattern + has more than the expected number of type arguments + + Example(s): + f (Just @Int @Bool x) = x + + Test cases: typecheck/should_fail/TyAppPat_TooMany + typecheck/should_fail/T20443b + -} + TcRnTooManyTyArgsInConPattern + :: !ConLike + -> !Int -- ^ Expected number of args + -> !Int -- ^ Actual number of args + -> TcRnMessage + + {- TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas + reference the same definition. + + Example(s): + {-# INLINE foo #-} + {-# INLINE foo #-} + foo :: Bool -> Bool + foo = id + + Test cases: none + -} + TcRnMultipleInlinePragmas + :: !Id -- ^ Target of the pragmas + -> !(LocatedA InlinePragma) -- ^ The first pragma + -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas + -> TcRnMessage + + {- TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear + in the source. + + Example(s): + + Test cases: none + -} + TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage + + {- TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being + placed on a definition that is not overloaded. + + Example(s): + {-# SPECIALISE foo :: Bool -> Bool #-} + foo :: Bool -> Bool + foo = id + + Test cases: simplCore/should_compile/T8537 + typecheck/should_compile/T10504 + -} + TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage + + {- TcRnSpecialiseNotVisible is a warning that occurs when the subject of a + SPECIALISE pragma has a definition that is not visible from the current module. + + Example(s): none + + Test cases: none + -} + TcRnSpecialiseNotVisible :: !Name -> TcRnMessage + + {- TcRnNameByTemplateHaskellQuote is an error that occurs when one tries + to use a Template Haskell splice to define a top-level identifier with + an already existing name. + + (See issue #13968 (closed) on GHC's issue tracker for more details) + + Example(s): + + $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) + + Test cases: + T13968 + -} + TcRnNameByTemplateHaskellQuote :: !RdrName -> TcRnMessage + + {- TcRnIllegalBindingOfBuiltIn is an error that occurs when one uses built-in + syntax for data constructors or class names. + + Use an OccName here because we don't want to print Prelude.(,) + + Test cases: + rename/should_fail/T14907b + rename/should_fail/rnfail042 + -} + TcRnIllegalBindingOfBuiltIn :: !OccName -> TcRnMessage + + {- TcRnPragmaWarning is a warning that can happen when usage of something + is warned or deprecated by pragma. + + Test cases: + DeprU + T5281 + T5867 + rn050 + rn066 (here is a warning, not deprecation) + T3303 + -} + TcRnPragmaWarning :: { + pragma_warning_occ :: OccName, + pragma_warning_msg :: WarningTxt GhcRn, + pragma_warning_import_mod :: ModuleName, + pragma_warning_defined_mod :: ModuleName + } -> TcRnMessage + + + {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for + a class default method is provided in a Backpack signature file. + + Test case: + bkpfail40 + -} + + TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class + -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods + -> TcRnMessage + {-| TcRnBadGenericMethod + This test ensures that if you provide a "more specific" type signatures + for the default method, you must also provide a binding. + + Example: + {-# LANGUAGE DefaultSignatures #-} + + class C a where + meth :: a + default meth :: Num a => a + meth = 0 + + Test case: + testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs + -} + TcRnBadGenericMethod :: !Name -- ^ 'Name' of the class + -> !Name -- ^ Problematic method + -> TcRnMessage + + {-| TcRnWarningMinimalDefIncomplete is a warning that one must + specify which methods must be implemented by all instances. + + Example: + class Cheater a where -- WARNING LINE + cheater :: a + {-# MINIMAL #-} -- warning! + + Test case: + testsuite/tests/warnings/minimal/WarnMinimal.hs: + -} + TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage + + {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when + a default method pragma is missing an accompanying binding. + + Test cases: + testsuite/tests/typecheck/should_fail/T5084.hs + testsuite/tests/typecheck/should_fail/T2354.hs + -} + TcRnDefaultMethodForPragmaLacksBinding + :: Id -- ^ method + -> Sig GhcRn -- ^ the pragma + -> TcRnMessage + {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when + a specialise pragma is put on a default method. + + Test cases: none + -} + TcRnIgnoreSpecialisePragmaOnDefMethod + :: !Name + -> TcRnMessage + {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method + in a class instance, when the class doesn't have a method by that name. + + Test case: + testsuite/tests/th/T12387 + -} + TcRnBadMethodErr + :: { badMethodErrClassName :: !Name + , badMethodErrMethodName :: !Name + } -> TcRnMessage + {-| TcRnNoExplicitAssocTypeOrDefaultDeclaration is an error that occurs + when a class instance does not provide an expected associated type + or default declaration. + + Test cases: + testsuite/tests/deriving/should_compile/T14094 + testsuite/tests/indexed-types/should_compile/Simple2 + testsuite/tests/typecheck/should_compile/tc254 + -} + TcRnNoExplicitAssocTypeOrDefaultDeclaration + :: Name + -> TcRnMessage + {-| TcRnIllegalNewtype is an error that occurs when a newtype: + + * Does not have exactly one field, or + * is non-linear, or + * is a GADT, or + * has a context in its constructor's type, or + * has existential type variables in its constructor's type, or + * has strictness annotations. + + Test cases: + testsuite/tests/gadt/T14719 + testsuite/tests/indexed-types/should_fail/T14033 + testsuite/tests/indexed-types/should_fail/T2334A + testsuite/tests/linear/should_fail/LinearGADTNewtype + testsuite/tests/parser/should_fail/readFail008 + testsuite/tests/polykinds/T11459 + testsuite/tests/typecheck/should_fail/T15523 + testsuite/tests/typecheck/should_fail/T15796 + testsuite/tests/typecheck/should_fail/T17955 + testsuite/tests/typecheck/should_fail/T18891a + testsuite/tests/typecheck/should_fail/T21447 + testsuite/tests/typecheck/should_fail/tcfail156 + -} + TcRnIllegalNewtype + :: DataCon + -> Bool -- ^ True if linear types enabled + -> IllegalNewtypeReason + -> TcRnMessage + + {-| TcRnIllegalTypeData is an error that occurs when a @type data@ + declaration occurs without the TypeOperators extension. + + See Note [Type data declarations] + + Test case: + testsuite/tests/type-data/should_fail/TDNoPragma + -} + TcRnIllegalTypeData :: TcRnMessage + + {-| TcRnTypeDataForbids is an error that occurs when a @type data@ + declaration contains @data@ declaration features that are + forbidden in a @type data@ declaration. + + See Note [Type data declarations] + + Test cases: + testsuite/tests/type-data/should_fail/TDDeriving + testsuite/tests/type-data/should_fail/TDRecordsGADT + testsuite/tests/type-data/should_fail/TDRecordsH98 + testsuite/tests/type-data/should_fail/TDStrictnessGADT + testsuite/tests/type-data/should_fail/TDStrictnessH98 + -} + TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage + + {-| TcRnTypedTHWithPolyType is an error that signifies the illegal use + of a polytype in a typed template haskell expression. + + Example(s): + bad :: (forall a. a -> a) -> () + bad = $$( [|| \_ -> () ||] ) + + Test cases: th/T11452 + -} + TcRnTypedTHWithPolyType :: !TcType -> TcRnMessage + + {-| TcRnSpliceThrewException is an error that occurrs when running a template + haskell splice throws an exception. + + Example(s): + + Test cases: annotations/should_fail/annfail12 + perf/compiler/MultiLayerModulesTH_Make + perf/compiler/MultiLayerModulesTH_OneShot + th/T10796b + th/T19470 + th/T19709d + th/T5358 + th/T5976 + th/T7276a + th/T8987 + th/TH_exn1 + th/TH_exn2 + th/TH_runIO + -} + TcRnSpliceThrewException + :: !SplicePhase + -> !SomeException + -> !String -- ^ Result of showing the exception (cannot be done safely outside IO) + -> !(LHsExpr GhcTc) + -> !Bool -- True <=> Print the expression + -> TcRnMessage + + {-| TcRnInvalidTopDecl is a template haskell error occurring when one of the 'Dec's passed to + 'addTopDecls' is not a function, value, annotation, or foreign import declaration. + + Example(s): + + Test cases: + -} + TcRnInvalidTopDecl :: !(HsDecl GhcPs) -> TcRnMessage + + {-| TcRnNonExactName is a template haskell error for when a declaration being + added is bound to a name that is not fully known. + + Example(s): + + Test cases: + -} + TcRnNonExactName :: !RdrName -> TcRnMessage + + {-| TcRnAddInvalidCorePlugin is a template haskell error indicating that a + core plugin being added has an invalid module due to being in the current package. + + Example(s): + + Test cases: + -} + TcRnAddInvalidCorePlugin + :: !String -- ^ Module name + -> TcRnMessage + + {-| TcRnAddDocToNonLocalDefn is a template haskell error for documentation being added to a + definition which is not in the current module. + + Example(s): + + Test cases: showIface/should_fail/THPutDocExternal + -} + TcRnAddDocToNonLocalDefn :: !TH.DocLoc -> TcRnMessage + + {-| TcRnFailedToLookupThInstName is a template haskell error that occurrs when looking up an + instance fails. + + Example(s): + + Test cases: showIface/should_fail/THPutDocNonExistent + -} + TcRnFailedToLookupThInstName :: !TH.Type -> !LookupTHInstNameErrReason -> TcRnMessage + + {-| TcRnCannotReifyInstance is a template haskell error for when an instance being reified + via `reifyInstances` is not a class constraint or type family application. + + Example(s): + + Test cases: + -} + TcRnCannotReifyInstance :: !Type -> TcRnMessage + + {-| TcRnCannotReifyOutOfScopeThing is a template haskell error indicating + that the given name is not in scope and therefore cannot be reified. + + Example(s): + + Test cases: th/T16976f + -} + TcRnCannotReifyOutOfScopeThing :: !TH.Name -> TcRnMessage + + {-| TcRnCannotReifyThingNotInTypeEnv is a template haskell error occurring + when the given name is not in the type environment and therefore cannot be reified. + + Example(s): + + Test cases: + -} + TcRnCannotReifyThingNotInTypeEnv :: !Name -> TcRnMessage + + {-| TcRnNoRolesAssociatedWithName is a template haskell error for when the user + tries to reify the roles of a given name but it is not something that has + roles associated with it. + + Example(s): + + Test cases: + -} + TcRnNoRolesAssociatedWithThing :: !TcTyThing -> TcRnMessage + + {-| TcRnCannotRepresentThing is a template haskell error indicating that a + type cannot be reified because it does not have a representation in template haskell. + + Example(s): + + Test cases: + -} + TcRnCannotRepresentType :: !UnrepresentableTypeDescr -> !Type -> TcRnMessage + + {-| TcRnRunSpliceFailure is an error indicating that a template haskell splice + failed to be converted into a valid expression. + + Example(s): + + Test cases: th/T10828a + th/T10828b + th/T12478_4 + th/T15270A + th/T15270B + th/T16895a + th/T16895b + th/T16895c + th/T16895d + th/T16895e + th/T17379a + th/T17379b + th/T18740d + th/T2597b + th/T2674 + th/T3395 + th/T7484 + th/T7667a + th/TH_implicitParamsErr1 + th/TH_implicitParamsErr2 + th/TH_implicitParamsErr3 + th/TH_invalid_add_top_decl + -} + TcRnRunSpliceFailure + :: !(Maybe String) -- ^ Name of the function used to run the splice + -> !RunSpliceFailReason + -> TcRnMessage + + {-| TcRnUserErrReported is an error or warning thrown using 'qReport' from + the 'Quasi' instance of 'TcM'. + + Example(s): + + Test cases: + -} + TcRnReportCustomQuasiError + :: !Bool -- True => Error, False => Warning + -> !String -- Error body + -> TcRnMessage + + {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file. + + Example(s): + + Test cases: + -} + TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage + + {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance + is missing methods that are required by the minimal definition. + + Example: + class C a where + foo :: a -> a + instance C () -- | foo needs to be defined here + + Test cases: + testsuite/tests/typecheck/prog001/typecheck.prog001 + testsuite/tests/typecheck/should_compile/tc126 + testsuite/tests/typecheck/should_compile/T7903 + testsuite/tests/typecheck/should_compile/tc116 + testsuite/tests/typecheck/should_compile/tc175 + testsuite/tests/typecheck/should_compile/HasKey + testsuite/tests/typecheck/should_compile/tc125 + testsuite/tests/typecheck/should_compile/tc078 + testsuite/tests/typecheck/should_compile/tc161 + testsuite/tests/typecheck/should_fail/T5051 + testsuite/tests/typecheck/should_compile/T21583 + testsuite/tests/backpack/should_compile/bkp47 + testsuite/tests/backpack/should_fail/bkpfail25 + testsuite/tests/parser/should_compile/T2245 + testsuite/tests/parser/should_compile/read014 + testsuite/tests/indexed-types/should_compile/Class3 + testsuite/tests/indexed-types/should_compile/Simple2 + testsuite/tests/indexed-types/should_fail/T7862 + testsuite/tests/deriving/should_compile/deriving-1935 + testsuite/tests/deriving/should_compile/T9968a + testsuite/tests/deriving/should_compile/drv003 + testsuite/tests/deriving/should_compile/T4966 + testsuite/tests/deriving/should_compile/T14094 + testsuite/tests/perf/compiler/T15304 + testsuite/tests/warnings/minimal/WarnMinimal + testsuite/tests/simplCore/should_compile/simpl020 + testsuite/tests/deSugar/should_compile/T14546d + testsuite/tests/ghci/scripts/T5820 + testsuite/tests/ghci/scripts/ghci019 + -} + TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage + + {- | 'TcRnMisplacedInstSig' is an error that happens when a method in + a class instance is given a type signature, but the user has not + enabled the @InstanceSigs@ extension. + + Test case: + testsuite/tests/module/mod45 + -} + TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage + {- | 'TcRnBadBootFamInstDecl' is an error that is triggered by a + type family instance being declared in an hs-boot file. + + Test case: + testsuite/tests/indexed-types/should_fail/HsBootFam + -} + TcRnBadBootFamInstDecl :: {} -> TcRnMessage + {- | 'TcRnIllegalFamilyInstance' is an error that occurs when an associated + type or data family is given a top-level instance. + + Test case: + testsuite/tests/indexed-types/should_fail/T3092 + -} + TcRnIllegalFamilyInstance :: TyCon -> TcRnMessage + {- | 'TcRnMissingClassAssoc' is an error that occurs when a class instance + for a class with an associated type or data family is missing a corresponding + family instance declaration. + + Test case: + testsuite/tests/indexed-types/should_fail/SimpleFail7 + -} + TcRnMissingClassAssoc :: TyCon -> TcRnMessage + {- | 'TcRnBadFamInstDecl' is an error that is triggered by a type or data family + instance without the @TypeFamilies@ extension. + + Test case: + testsuite/tests/indexed-types/should_fail/BadFamInstDecl + -} + TcRnBadFamInstDecl :: TyCon -> TcRnMessage + {- | 'TcRnNotOpenFamily' is an error that is triggered by attempting to give + a top-level (open) type family instance for a closed type family. + + Test cases: + testsuite/tests/indexed-types/should_fail/Overlap7 + testsuite/tests/indexed-types/should_fail/Overlap3 + -} + TcRnNotOpenFamily :: TyCon -> TcRnMessage + {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update + without RebindableSyntax enabled. + + Example(s): + + Test cases: parser/should_fail/RecordDotSyntaxFail5 + -} + TcRnNoRebindableSyntaxRecordDot :: TcRnMessage + + {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns + in an overloaded record update without enabling NamedFieldPuns. + + Example(s): + print $ a{ foo.bar.baz.quux } + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnNoFieldPunsRecordDot :: TcRnMessage + + {-| TcRnIllegalStaticExpression is an error thrown when user creates a static + pointer via TemplateHaskell without enabling the StaticPointers extension. + + Example(s): + + Test cases: th/T14204 + -} + TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnIllegalStaticFormInSplice is an error when a user attempts to define + a static pointer in a Template Haskell splice. + + Example(s): + + Test cases: th/TH_StaticPointers02 + -} + TcRnIllegalStaticFormInSplice :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate + let-bindings in a list comprehension. + + Example(s): + [ () | let a = 13 | let a = 17 ] + + Test cases: typecheck/should_fail/tcfail092 + -} + TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage + + {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements + in a statement block. For more information, see 'EmptyStatementGroupErrReason' + + Example(s): + + [() | then ()] + + do + + proc () -> do + + Test cases: rename/should_fail/RnEmptyStatementGroup1 + -} + TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage + + {-| TcRnLastStmtNotExpr is an error caused by the last statement + in a statement block not being an expression. + + Example(s): + + do x <- pure () + + do let x = 5 + + Test cases: rename/should_fail/T6060 + parser/should_fail/T3811g + parser/should_fail/readFail028 + -} + TcRnLastStmtNotExpr + :: HsStmtContext GhcRn + -> UnexpectedStatement + -> TcRnMessage + + {-| TcRnUnexpectedStatementInContext is an error when a statement appears + in an unexpected context (e.g. an arrow statement appears in a list comprehension). + + Example(s): + + Test cases: parser/should_fail/readFail042 + parser/should_fail/readFail038 + parser/should_fail/readFail043 + -} + TcRnUnexpectedStatementInContext + :: HsStmtContext GhcRn + -> UnexpectedStatement + -> Maybe LangExt.Extension + -> TcRnMessage + + {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section + without enabling the TupleSections extension. + + Example(s): + (5,) + + Test cases: rename/should_fail/rnfail056 + -} + TcRnIllegalTupleSection :: TcRnMessage + + {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding + an implicit parameter in an mdo block. + + Example(s): + mdo { let { ?x = 5 }; () } + + Test cases: rename/should_fail/RnImplicitBindInMdoNotation + -} + TcRnIllegalImplicitParameterBindings + :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) + -> TcRnMessage + + {-| TcRnSectionWithoutParentheses is an error triggered by attempting to + use an operator section without parentheses. + + Example(s): + (`head` x, ()) + + Test cases: rename/should_fail/T2490 + rename/should_fail/T5657 + -} + TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@, + that is triggered when GHC solves a constraint in a possibly-loopy way, + violating the class instance termination rules described in the section + "Undecidable instances and loopy superclasses" of the user's guide. + + Example: + + class Foo f + class Foo f => Bar f g + instance Bar f f => Bar f (h k) + + Test cases: T20666, T20666{a,b}, T22891, T22912. + -} + TcRnLoopySuperclassSolve :: CtLoc -- ^ Wanted 'CtLoc' + -> PredType -- ^ Wanted 'PredType' + -> TcRnMessage + + deriving Generic + +-- | Things forbidden in @type data@ declarations. +-- See Note [Type data declarations] +data TypeDataForbids + = TypeDataForbidsDatatypeContexts + | TypeDataForbidsLabelledFields + | TypeDataForbidsStrictnessAnnotations + | TypeDataForbidsDerivingClauses + deriving Generic + +instance Outputable TypeDataForbids where + ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" + ppr TypeDataForbidsLabelledFields = text "Labelled fields" + ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" + ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" + +data RunSpliceFailReason + = ConversionFail !ThingBeingConverted !ConversionFailReason + deriving Generic + +-- | Identifies the TH splice attempting to be converted +data ThingBeingConverted + = ConvDec !TH.Dec + | ConvExp !TH.Exp + | ConvPat !TH.Pat + | ConvType !TH.Type + +-- | The reason a TH splice could not be converted to a Haskell expression +data ConversionFailReason + = IllegalOccName !OccName.NameSpace !String + | SumAltArityExceeded !TH.SumAlt !TH.SumArity + | IllegalSumAlt !TH.SumAlt + | IllegalSumArity !TH.SumArity + | MalformedType !TypeOrKind !TH.Type + | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs)) + | KindSigsOnlyAllowedOnGADTs + | IllegalDeclaration !THDeclDescriptor !IllegalDecls + | CannotMixGADTConsWith98Cons + | EmptyStmtListInDoBlock + | NonVarInInfixExpr + | MultiWayIfWithoutAlts + | CasesExprWithoutAlts + | ImplicitParamsWithOtherBinds + | InvalidCCallImpent !String -- ^ Source + | RecGadtNoCons + | GadtNoCons + | InvalidTypeInstanceHeader !TH.Type + | InvalidTyFamInstLHS !TH.Type + | InvalidImplicitParamBinding + | DefaultDataInstDecl ![LDataFamInstDecl GhcPs] + | FunBindLacksEquations !TH.Name + deriving Generic + +data IllegalDecls + = IllegalDecls !(NE.NonEmpty (LHsDecl GhcPs)) + | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs)) + +-- | Label for a TH declaration +data THDeclDescriptor + = InstanceDecl + | WhereClause + | LetBinding + | LetExpression + | ClssDecl + +-- | Specifies which back ends can handle a requested foreign import or export +type ExpectedBackends = [Backend] + +-- | Specifies which calling convention is unsupported on the current platform +data UnsupportedCallConvention + = StdCallConvUnsupported + | PrimCallConvUnsupported + | JavaScriptCallConvUnsupported + deriving Eq + +-- | Whether the error pertains to a function argument or a result. +data ArgOrResult + = Arg | Result + +-- | Which parts of a record field are affected by a particular error or warning. +data RecordFieldPart + = RecordFieldConstructor !Name + | RecordFieldPattern !Name + | RecordFieldUpdate + +-- | Where a shadowed name comes from +data ShadowedNameProvenance + = ShadowedNameProvenanceLocal !SrcLoc + -- ^ The shadowed name is local to the module + | ShadowedNameProvenanceGlobal [GlobalRdrElt] + -- ^ The shadowed name is global, typically imported from elsewhere. + +-- | In what context did we require a type to have a fixed runtime representation? +-- +-- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing +-- representation polymorphism errors when validity checking. +-- +-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +data FixedRuntimeRepProvenance + -- | Data constructor fields must have a fixed runtime representation. + -- + -- Tests: T11734, T18534. + = FixedRuntimeRepDataConField + + -- | Pattern synonym signature arguments must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynArg. + | FixedRuntimeRepPatSynSigArg + + -- | Pattern synonym signature scrutinee must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynRes. + | FixedRuntimeRepPatSynSigRes + +pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc +pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee" + +-- | Why the particular illegal newtype error arose together with more +-- information, if any. +data IllegalNewtypeReason + = DoesNotHaveSingleField !Int + | IsNonLinear + | IsGADT + | HasConstructorContext + | HasExistentialTyVar + | HasStrictnessAnnotation + deriving Generic + +-- | Why the particular injectivity error arose together with more information, +-- if any. +data InjectivityErrReason + = InjErrRhsBareTyVar [Type] + | InjErrRhsCannotBeATypeFam + | InjErrRhsOverlap + | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances + +data HasKinds + = YesHasKinds + | NoHasKinds + deriving (Show, Eq) + +hasKinds :: Bool -> HasKinds +hasKinds True = YesHasKinds +hasKinds False = NoHasKinds + +data SuggestUndecidableInstances + = YesSuggestUndecidableInstaces + | NoSuggestUndecidableInstaces + deriving (Show, Eq) + +suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances +suggestUndecidableInstances True = YesSuggestUndecidableInstaces +suggestUndecidableInstances False = NoSuggestUndecidableInstaces + +data SuggestUnliftedTypes + = SuggestUnliftedNewtypes + | SuggestUnliftedDatatypes + +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +ppDataSort :: DataSort -> SDoc +ppDataSort data_sort = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + +-- | Helper type used in 'checkDataKindSig'. +-- +-- Superficially similar to 'ContextKind', but it lacks 'AnyKind' +-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ +-- provides 'LiftedKind', which is much simpler to match on and +-- handle in 'isAllowedDataResKind'. +data AllowedDataResKind + = AnyTYPEKind + | AnyBoxedKind + | LiftedKind + +-- | A data type to describe why a variable is not closed. +-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +data SuggestPartialTypeSignatures + = YesSuggestPartialTypeSignatures + | NoSuggestPartialTypeSignatures + deriving (Show, Eq) + +suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures +suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures +suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures + +data UsingGeneralizedNewtypeDeriving + = YesGeneralizedNewtypeDeriving + | NoGeneralizedNewtypeDeriving + deriving Eq + +usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving + +data DeriveAnyClassEnabled + = YesDeriveAnyClassEnabled + | NoDeriveAnyClassEnabled + deriving Eq + +deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled +deriveAnyClassEnabled True = YesDeriveAnyClassEnabled +deriveAnyClassEnabled False = NoDeriveAnyClassEnabled + +-- | Why a particular typeclass instance couldn't be derived. +data DeriveInstanceErrReason + = + -- | The typeclass instance is not well-kinded. + DerivErrNotWellKinded !TyCon + -- ^ The type constructor that occurs in + -- the typeclass instance declaration. + !Kind + -- ^ The typeclass kind. + !Int + -- ^ The number of typeclass arguments that GHC + -- kept. See Note [tc_args and tycon arity] in + -- GHC.Tc.Deriv. + -- | Generic instances can only be derived using the stock strategy + -- in Safe Haskell. + | DerivErrSafeHaskellGenericInst + | DerivErrDerivingViaWrongKind !Kind !Type !Kind + | DerivErrNoEtaReduce !Type + -- ^ The instance type + -- | We cannot derive instances in boot files + | DerivErrBootFileFound + | DerivErrDataConsNotAllInScope !TyCon + -- | We cannot use GND on non-newtype types + | DerivErrGNDUsedOnData + -- | We cannot derive instances of nullary classes + | DerivErrNullaryClasses + -- | Last arg must be newtype or data application + | DerivErrLastArgMustBeApp + | DerivErrNoFamilyInstance !TyCon [Type] + | DerivErrNotStockDeriveable !DeriveAnyClassEnabled + | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts + !AssociatedTyLastVarInKind + !AssociatedTyNotParamOverLastTyVar + | DerivErrNewtypeNonDeriveableClass + | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? + | DerivErrOnlyAnyClassDeriveable !TyCon + -- ^ Type constructor for which the instance + -- is requested + !DeriveAnyClassEnabled + -- ^ Whether or not -XDeriveAnyClass is enabled + -- already. + -- | Stock deriving won't work, but perhaps DeriveAnyClass will. + | DerivErrNotDeriveable !DeriveAnyClassEnabled + -- | The given 'PredType' is not a class. + | DerivErrNotAClass !PredType + -- | The given (representation of the) 'TyCon' has no + -- data constructors. + | DerivErrNoConstructors !TyCon + | DerivErrLangExtRequired !LangExt.Extension + -- | GHC simply doesn't how to how derive the input 'Class' for the given + -- 'Type'. + | DerivErrDunnoHowToDeriveForType !Type + -- | The given 'TyCon' must be an enumeration. + -- See Note [Enumeration types] in GHC.Core.TyCon + | DerivErrMustBeEnumType !TyCon + -- | The given 'TyCon' must have /precisely/ one constructor. + | DerivErrMustHaveExactlyOneConstructor !TyCon + -- | The given data type must have some parameters. + | DerivErrMustHaveSomeParameters !TyCon + -- | The given data type must not have a class context. + | DerivErrMustNotHaveClassContext !TyCon !ThetaType + -- | We couldn't derive an instance for a particular data constructor + -- for a variety of reasons. + | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] + -- | We couldn't derive a 'Generic' instance for the given type for a + -- variety of reasons + | DerivErrGenerics [DeriveGenericsErrReason] + -- | We couldn't derive an instance either because the type was not an + -- enum type or because it did have more than one constructor. + | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason + deriving Generic + +data DeriveInstanceBadConstructor + = + -- | The given 'DataCon' must be truly polymorphic in the + -- last argument of the data type. + DerivErrBadConExistential !DataCon + -- | The given 'DataCon' must not use the type variable in a function argument" + | DerivErrBadConCovariant !DataCon + -- | The given 'DataCon' must not contain function types + | DerivErrBadConFunTypes !DataCon + -- | The given 'DataCon' must use the type variable only + -- as the last argument of a data type + | DerivErrBadConWrongArg !DataCon + -- | The given 'DataCon' is a GADT so we cannot directly + -- derive an istance for it. + | DerivErrBadConIsGADT !DataCon + -- | The given 'DataCon' has existentials type vars in its type. + | DerivErrBadConHasExistentials !DataCon + -- | The given 'DataCon' has constraints in its type. + | DerivErrBadConHasConstraints !DataCon + -- | The given 'DataCon' has a higher-rank type. + | DerivErrBadConHasHigherRankType !DataCon + +data DeriveGenericsErrReason + = -- | The type must not have some datatype context. + DerivErrGenericsMustNotHaveDatatypeContext !TyCon + -- | The data constructor must not have exotic unlifted + -- or polymorphic arguments. + | DerivErrGenericsMustNotHaveExoticArgs !DataCon + -- | The data constructor must be a vanilla constructor. + | DerivErrGenericsMustBeVanillaDataCon !DataCon + -- | The type must have some type parameters. + -- check (d) from Note [Requirements for deriving Generic and Rep] + -- in GHC.Tc.Deriv.Generics. + | DerivErrGenericsMustHaveSomeTypeParams !TyCon + -- | The data constructor must not have existential arguments. + | DerivErrGenericsMustNotHaveExistentials !DataCon + -- | The derivation applies a type to an argument involving + -- the last parameter but the applied type is not of kind * -> *. + | DerivErrGenericsWrongArgKind !DataCon + +data HasWildcard + = YesHasWildcard + | NoHasWildcard + deriving Eq + +hasWildcard :: Bool -> HasWildcard +hasWildcard True = YesHasWildcard +hasWildcard False = NoHasWildcard + +-- | A context in which we don't allow anonymous wildcards. +data BadAnonWildcardContext + = WildcardNotLastInConstraint + | ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed + | WildcardsNotAllowedAtAll + +-- | Whether a sole extra-constraint wildcard is allowed, +-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. +data SoleExtraConstraintWildcardAllowed + = SoleExtraConstraintWildcardNotAllowed + | SoleExtraConstraintWildcardAllowed + +-- | A type representing whether or not the input type has associated data family instances. +data HasAssociatedDataFamInsts + = YesHasAdfs + | NoHasAdfs + deriving Eq + +hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts +hasAssociatedDataFamInsts True = YesHasAdfs +hasAssociatedDataFamInsts False = NoHasAdfs + +-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass +-- contains the last type variable of the class in a kind, which is not (yet) allowed +-- by GHC. +data AssociatedTyLastVarInKind + = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class + | NoAssocTyLastVarInKind + deriving Eq + +associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind +associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc +associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind + +-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a +-- typeclass is not parameterized over the last type variable of the class +data AssociatedTyNotParamOverLastTyVar + = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class + | NoAssociatedTyNotParamOverLastTyVar + deriving Eq + +associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar +associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc +associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar + +-- | What kind of thing is missing a type signature? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'tcRnMissingSignature'. +data MissingSignature + = MissingTopLevelBindingSig Name Type + | MissingPatSynSig PatSyn + | MissingTyConKindSig + TyCon + Bool -- ^ whether -XCUSKs is enabled + +-- | Is the object we are dealing with exported or not? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'TcRnMissingSignature'. +data Exported + = IsNotExported + | IsExported + +instance Outputable Exported where + ppr IsNotExported = text "IsNotExported" + ppr IsExported = text "IsExported" + +-------------------------------------------------------------------------------- +-- +-- Errors used in GHC.Tc.Errors +-- +-------------------------------------------------------------------------------- + +{- Note [Error report] +~~~~~~~~~~~~~~~~~~~~~~ +The idea is that error msgs are divided into three parts: the main msg, the +context block ("In the second argument of ..."), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. +-} + +-- | A collection of main error messages and supplementary information. +-- +-- In practice, we will: +-- - display the important messages first, +-- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), +-- - then the supplementary information (e.g. relevant bindings, valid hole fits), +-- - then the hints ("Possible fix: ..."). +-- +-- So this is mostly just a way of making sure that the error context appears +-- early on rather than at the end of the message. +-- +-- See Note [Error report] for details. +data SolverReport + = SolverReport + { sr_important_msg :: SolverReportWithCtxt + , sr_supplementary :: [SolverReportSupplementary] + , sr_hints :: [GhcHint] + } + +-- | Additional information to print in a 'SolverReport', after the +-- important messages and after the error context. +-- +-- See Note [Error report]. +data SolverReportSupplementary + = SupplementaryBindings RelevantBindings + | SupplementaryHoleFits ValidHoleFits + | SupplementaryCts [(PredType, RealSrcSpan)] + +-- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) +-- that are needed in order to report it. +data SolverReportWithCtxt = + SolverReportWithCtxt + { reportContext :: SolverReportErrCtxt + -- ^ Context for what we wish to report. + -- This can change as we enter implications, so is + -- stored alongside the content. + , reportContent :: TcSolverReportMsg + -- ^ The content of the message to report. + } + deriving Generic + +-- | Context needed when reporting a 'TcSolverReportMsg', such as +-- the enclosing implication constraints or whether we are deferring type errors. +data SolverReportErrCtxt + = CEC { cec_encl :: [Implication] -- ^ Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- ^ We make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime + + -- We might throw a warning on an error when encountering a hole, + -- depending on the type of hole (expression hole, type hole, out of scope hole). + -- We store the reasons for reporting a diagnostic for each type of hole. + , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions. + , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes. + + , cec_warn_redundant :: Bool -- ^ True <=> -Wredundant-constraints + , cec_expand_syns :: Bool -- ^ True <=> -fprint-expanded-synonyms + + , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +getUserGivens :: SolverReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + +---------------------------------------------------------------------------- +-- +-- ErrorItem +-- +---------------------------------------------------------------------------- + +-- | A predicate with its arising location; used to encapsulate a constraint +-- that will give rise to a diagnostic. +data ErrorItem +-- We could perhaps use Ct here (and indeed used to do exactly that), but +-- having a separate type gives to denote errors-in-formation gives us +-- a nice place to do pre-processing, such as calculating ei_suppress. +-- Perhaps some day, an ErrorItem could eventually evolve to contain +-- the error text (or some representation of it), so we can then have all +-- the errors together when deciding which to report. + = EI { ei_pred :: PredType -- report about this + -- The ei_pred field will never be an unboxed equality with + -- a (casted) tyvar on the right; this is guaranteed by the solver + , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence + , ei_flavour :: CtFlavour + , ei_loc :: CtLoc + , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a + -- CtIrred, this stores the reason + , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Constraint + } + +instance Outputable ErrorItem where + ppr (EI { ei_pred = pred + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_suppress = supp }) + = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred + where + pp_dest Nothing = empty + pp_dest (Just ev) = ppr ev <+> dcolon + + pp_supp = if supp then text "suppress:" else empty + +errorItemOrigin :: ErrorItem -> CtOrigin +errorItemOrigin = ctLocOrigin . ei_loc + +errorItemEqRel :: ErrorItem -> EqRel +errorItemEqRel = predTypeEqRel . ei_pred + +errorItemCtLoc :: ErrorItem -> CtLoc +errorItemCtLoc = ei_loc + +errorItemPred :: ErrorItem -> PredType +errorItemPred = ei_pred + +{- Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... +-} + + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + + +-- | An error reported after constraint solving. +-- This is usually, some sort of unsolved constraint error, +-- but we try to be specific about the precise problem we encountered. +data TcSolverReportMsg + -- | Quantified variables appear out of dependency order. + -- + -- Example: + -- + -- forall (a :: k) k. ... + -- + -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. + = BadTelescope TyVarBndrs [TyCoVar] + + -- | We came across a custom type error and we have decided to report it. + -- + -- Example: + -- + -- type family F a where + -- F a = TypeError (Text "error") + -- + -- err :: F () + -- err = () + -- + -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. + | UserTypeError Type + + -- | We want to report an out of scope variable or a typed hole. + -- See 'HoleError'. + | ReportHoleError Hole HoleError + + -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. + -- + -- Test case: Simple14 + | UntouchableVariable + { untouchableTyVar :: TyVar + , untouchableTyVarImplication :: Implication + } + + -- | Cannot unify a variable, because of a type mismatch. + | CannotUnifyVariable + { mismatchMsg :: MismatchMsg + , cannotUnifyReason :: CannotUnifyVariableReason } + + -- | A mismatch between two types. + | Mismatch + { mismatchMsg :: MismatchMsg + , mismatchTyVarInfo :: Maybe TyVarInfo + , mismatchAmbiguityInfo :: [AmbiguityInfo] + , mismatchCoercibleInfo :: Maybe CoercibleMsg } + + -- | A violation of the representation-polymorphism invariants. + -- + -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. + | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] + + -- | An equality between two types is blocked on a kind equality + -- between their kinds. + -- + -- 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. + -- + -- Example: + -- + -- instance Eq Maybe where {..} + -- + -- Test case: T11563. + | ExpectingMoreArguments Int TypedThing + + -- | Trying to use an unbound implicit parameter. + -- + -- Example: + -- + -- foo :: Int + -- foo = ?param + -- + -- Test case: tcfail130. + | UnboundImplicitParams + (NE.NonEmpty ErrorItem) + + -- | A constraint couldn't be solved because it contains + -- ambiguous type variables. + -- + -- Example: + -- + -- class C a b where + -- f :: (a,b) + -- + -- x = fst f + -- + -- + -- Test case: T4921. + | AmbiguityPreventsSolvingCt + ErrorItem -- ^ always a class constraint + ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively + + -- | Could not solve a constraint; there were several unifying candidate instances + -- but no matching instances. This is used to report as much useful information + -- as possible about why we couldn't choose any instance, e.g. because of + -- ambiguous type variables. + | CannotResolveInstance + { cannotResolve_item :: ErrorItem + , cannotResolve_unifiers :: [ClsInst] + , cannotResolve_candidates :: [ClsInst] + , cannotResolve_importErrors :: [ImportError] + , cannotResolve_suggestions :: [GhcHint] + , cannotResolve_relevant_bindings :: RelevantBindings } + -- TODO: remove the fields of type [GhcHint] and RelevantBindings, + -- in order to handle them uniformly with other diagnostic messages. + + -- | Could not solve a constraint using available instances + -- because the instances overlap. + -- + -- Test cases: tcfail118, tcfail121, tcfail218. + | OverlappingInstances + { overlappingInstances_item :: ErrorItem + , overlappingInstances_matches :: NE.NonEmpty ClsInst + , overlappingInstances_unifiers :: [ClsInst] } + + -- | Could not solve a constraint from instances because + -- instances declared in a Safe module cannot overlap instances + -- from other modules (with -XSafeHaskell). + -- + -- Test cases: SH_Overlap{1,2,5,6,7,11}. + | UnsafeOverlap + { unsafeOverlap_item :: ErrorItem + , unsafeOverlap_match :: ClsInst + , unsafeOverlapped :: NE.NonEmpty ClsInst } + + deriving Generic + +data MismatchMsg + = -- | Couldn't unify two types or kinds. + -- + -- Example: + -- + -- 3 + 3# -- can't match a lifted type with an unlifted type + -- + -- Test cases: T1396, T8263, ... + 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) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + , mismatch_whenMatching :: Maybe WhenMatching + , mismatch_mb_same_occ :: Maybe SameOccInfo + } + + -- | A type has an unexpected kind. + -- + -- Test cases: T2994, T7609, ... + | KindMismatch + { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? + , kmismatch_expected :: Type + , kmismatch_actual :: Type + } + -- TODO: combine with 'BasicMismatch'. + + -- | A mismatch between two types, which arose from a type equality. + -- + -- Test cases: T1470, tcfail212. + | TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds :: Bool + , teq_mismatch_item :: ErrorItem + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type + , teq_mismatch_expected :: Type -- ^ The overall expected type + , teq_mismatch_actual :: Type -- ^ The overall actual type + , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? + , teq_mb_same_occ :: Maybe SameOccInfo + } + -- TODO: combine with 'BasicMismatch'. + + -- | Couldn't solve some Wanted constraints using the Givens. + -- Used for messages such as @"No instance for ..."@ and + -- @"Could not deduce ... from"@. + | CouldNotDeduce + { cnd_user_givens :: [Implication] + -- | The Wanted constraints we couldn't solve. + -- + -- N.B.: the 'ErrorItem' at the head of the list has been tidied, + -- perhaps not the others. + , cnd_wanted :: NE.NonEmpty ErrorItem + + -- | Some additional info consumed by 'mk_supplementary_ea_msg'. + , cnd_extra :: Maybe CND_Extra + } + 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 + { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = Nothing + } + +-- | Whether to use expected/actual in a type mismatch message. +data MismatchEA + -- | Don't use expected/actual. + = NoEA + -- | Use expected/actual. + | EA + { mismatch_mbEA :: Maybe ExpectedActualInfo + -- ^ Whether to also mention type synonym expansion. + } + +data CannotUnifyVariableReason + = -- | A type equality between a type variable and a polytype. + -- + -- Test cases: T12427a, T2846b, T10194, ... + CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo) + + -- | An occurs check. + | OccursCheck + { occursCheckInterestingTyVars :: [TyVar] + , occursCheckAmbiguityInfos :: [AmbiguityInfo] } + + -- | A skolem type variable escapes its scope. + -- + -- Example: + -- + -- data Ex where { MkEx :: a -> MkEx } + -- foo (MkEx x) = x + -- + -- Test cases: TypeSkolEscape, T11142. + | SkolemEscape ErrorItem Implication [TyVar] + + -- | Can't unify the type variable with the other type + -- due to the kind of type variable it is. + -- + -- For example, trying to unify a 'SkolemTv' with the + -- type Int, or with a 'TyVarTv'. + | DifferentTyVars TyVarInfo + | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) + deriving Generic + +-- | Report a mismatch error without any extra +-- information. +mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg +mkPlainMismatchMsg msg + = Mismatch + { mismatchMsg = msg + , mismatchTyVarInfo = Nothing + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + +-- | Additional information to be given in a 'CouldNotDeduce' message, +-- which is then passed on to 'mk_supplementary_ea_msg'. +data CND_Extra = CND_Extra TypeOrKind Type Type + +-- | A cue to print out information about type variables, +-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@. +data TyVarInfo = + TyVarInfo { thisTyVar :: TyVar + , thisTyVarIsUntouchable :: Maybe Implication + , otherTy :: Maybe TyVar } + +-- | Add some information to disambiguate errors in which +-- two 'Names' would otherwise appear to be identical. +-- +-- See Note [Disambiguating (X ~ X) errors]. +data SameOccInfo + = SameOcc + { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. + , sameOcc_lhs :: Name + , sameOcc_rhs :: Name } + +-- | Add some information about ambiguity +data AmbiguityInfo + + -- | Some type variables remained ambiguous: print them to the user. + = Ambiguity + { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." + -- False <=> create a message of the form "The type variable is ambiguous." + , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. + -- Guaranteed to not both be empty. + } + + -- | Remind the user that a particular type family is not injective. + | NonInjectiveTyFam TyCon + +-- | Expected/actual information. +data ExpectedActualInfo + -- | Display the expected and actual types. + = ExpectedActual + { ea_expected, ea_actual :: Type } + + -- | Display the expected and actual types, after expanding type synonyms. + | ExpectedActualAfterTySynExpansion + { ea_expanded_expected, ea_expanded_actual :: Type } + +-- | Explain how a kind equality originated. +data WhenMatching + + = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) + deriving Generic + +-- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' +-- constructor of 'HoleError'. +data NotInScopeError + + -- | A run-of-the-mill @"not in scope"@ error. + = NotInScope + + -- | An exact 'Name' was not in scope. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test cases: T5971, T18263. + | NoExactName Name + + -- The same exact 'Name' occurs in multiple name-spaces. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test case: T7241. + | SameName [GlobalRdrElt] -- ^ always at least 2 elements + + -- A type signature, fixity declaration, pragma, standalone kind signature... + -- is missing an associated binding. + | MissingBinding SDoc [GhcHint] + -- TODO: remove the SDoc argument. + + -- | Couldn't find a top-level binding. + -- + -- Happens when specifying an annotation for something that + -- is not in scope. + -- + -- Test cases: annfail01, annfail02, annfail11. + | NoTopLevelBinding + + -- | A class doesn't have a method with this name, + -- or, a class doesn't have an associated type with this name, + -- or, a record doesn't have a record field with this name. + | UnknownSubordinate SDoc + deriving Generic + +-- | Create a @"not in scope"@ error message for the given 'RdrName'. +mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage +mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints + +-- | Configuration for pretty-printing valid hole fits. +data HoleFitDispConfig = + HFDC { showWrap, showWrapVars, showType, showProv, showMatches + :: Bool } + +-- | Report an error involving a 'Hole'. +-- +-- This could be an out of scope data constructor or variable, +-- a typed hole, or a wildcard in a type. +data HoleError + -- | Report an out-of-scope data constructor or variable + -- masquerading as an expression hole. + -- + -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. + -- See 'NotInScopeError' for other not-in-scope errors. + -- + -- Test cases: T9177a. + = OutOfScopeHole [ImportError] + -- | Report a typed hole, or wildcard, with additional information. + | HoleError HoleSort + [TcTyVar] -- Other type variables which get computed on the way. + [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. + +-- | A message that aims to explain why two types couldn't be seen +-- to be representationally equal. +data CoercibleMsg + -- | Not knowing the role of a type constructor prevents us from + -- concluding that two types are representationally equal. + -- + -- Example: + -- + -- foo :: Applicative m => m (Sum Int) + -- foo = coerce (pure $ 1 :: Int) + -- + -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. + -- + -- Test cases: T8984, TcCoercibleFail. + = UnknownRoles Type + + -- | The fact that a 'TyCon' is abstract prevents us from decomposing + -- a 'TyConApp' and deducing that two types are representationally equal. + -- + -- Test cases: none. + | TyConIsAbstract TyCon + + -- | We can't unwrap a newtype whose constructor is not in scope. + -- + -- Example: + -- + -- import Data.Ord (Down) -- NB: not importing the constructor + -- foo :: Int -> Down Int + -- foo = coerce + -- + -- Test cases: TcCoercibleFail. + | OutOfScopeNewtypeConstructor TyCon DataCon + +-- | Explain a problem with an import. +data ImportError + -- | Couldn't find a module with the requested name. + = MissingModule ModuleName + -- | The imported modules don't export what we're looking for. + | ModulesDoNotExport (NE.NonEmpty Module) OccName + +-- | This datatype collates instances that match or unifier, +-- in order to report an error message for an unsolved typeclass constraint. +data PotentialInstances + = PotentialInstances + { matches :: [ClsInst] + , unifiers :: [ClsInst] + } + +-- | A collection of valid hole fits or refinement fits, +-- in which some fits might have been suppressed. +data FitsMbSuppressed + = Fits + { fits :: [HoleFit] + , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. + } + +-- | A collection of hole fits and refinement fits. +data ValidHoleFits + = ValidHoleFits + { holeFits :: FitsMbSuppressed + , refinementFits :: FitsMbSuppressed + } + +noValidHoleFits :: ValidHoleFits +noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) + +data RelevantBindings + = RelevantBindings + { relevantBindingNamesAndTys :: [(Name, Type)] + , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. + } + +-- | Display some relevant bindings. +pprRelevantBindings :: RelevantBindings -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but it's here for the moment as it's needed in "GHC.Tc.Errors". +pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = + ppUnless (null rel_bds) $ + hang (text "Relevant bindings include") + 2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg) + where + ppr_binding (nm, tidy_ty) = + sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc nm)))] + rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + +data PromotionErr + = TyConPE -- TyCon used in a kind before we are ready + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] + -- in GHC.Tc.Utils.Env. + | ConstrainedDataConPE PredType + -- Data constructor with a non-equality context + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl + | TermVariablePE -- See Note [Promoted variables in types] + | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr PatSynPE = text "PatSynPE" + ppr FamDataConPE = text "FamDataConPE" + ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" + <+> parens (ppr pred) + ppr RecDataConPE = text "RecDataConPE" + ppr NoDataKindsDC = text "NoDataKindsDC" + ppr TermVariablePE = text "TermVariablePE" + +pprPECategory :: PromotionErr -> SDoc +pprPECategory = text . capitalise . peCategory + +peCategory :: PromotionErr -> String +peCategory ClassPE = "class" +peCategory TyConPE = "type constructor" +peCategory PatSynPE = "pattern synonym" +peCategory FamDataConPE = "data constructor" +peCategory ConstrainedDataConPE{} = "data constructor" +peCategory RecDataConPE = "data constructor" +peCategory NoDataKindsDC = "data constructor" +peCategory TermVariablePE = "term variable" + +-- | Stores the information to be reported in a representation-polymorphism +-- error message. +data FixedRuntimeRepErrorInfo + = FRR_Info + { frr_info_origin :: FixedRuntimeRepOrigin + -- ^ What is the original type we checked for + -- representation-polymorphism, and what specific + -- check did we perform? + , frr_info_not_concrete :: Maybe (TcTyVar, TcType) + -- ^ Which non-concrete type did we try to + -- unify this concrete type variable with? + } + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. +data HsDocContext + = TypeSigCtx SDoc + | StandaloneKindSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (LocatedN RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (LocatedN RdrName) + | TySynCtx (LocatedN RdrName) + | TyFamilyCtx (LocatedN RdrName) + | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [LocatedN Name] + | ClassDeclCtx (LocatedN RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | HsTypePatCtx + | GHCiCtx + | SpliceTypeCtx (LHsType GhcPs) + | ClassInstanceCtx + | GenericCtx SDoc + +-- | Context for a mismatch in the number of arguments +data MatchArgsContext + = EquationArgs + !Name -- ^ Name of the function + | PatternArgs + !(HsMatchContext GhcTc) -- ^ Pattern match specifics + +-- | The information necessary to report mismatched +-- numbers of arguments in a match group. +data MatchArgBadMatches where + MatchArgMatches + :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) + , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } + -> MatchArgBadMatches + +-- | The phase in which an exception was encountered when dealing with a TH splice +data SplicePhase + = SplicePhase_Run + | SplicePhase_CompileAndLink + +data LookupTHInstNameErrReason + = NoMatchesFound + | CouldNotDetermineInstance + +data UnrepresentableTypeDescr + = LinearInvisibleArgument + | CoercionsInTypes + +-- | The context for an "empty statement group" error. +data EmptyStatementGroupErrReason + = EmptyStmtsGroupInParallelComp + -- ^ Empty statement group in a parallel list comprehension + | EmptyStmtsGroupInTransformListComp + -- ^ Empty statement group in a transform list comprehension + -- + -- Example: + -- [() | then ()] + | EmptyStmtsGroupInDoNotation HsDoFlavour + -- ^ Empty statement group in do notation + -- + -- Example: + -- do + | EmptyStmtsGroupInArrowNotation + -- ^ Empty statement group in arrow notation + -- + -- Example: + -- proc () -> do + + deriving (Generic) + +-- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@. +data UnexpectedStatement where + UnexpectedStatement + :: Outputable (StmtLR GhcPs GhcPs body) + => StmtLR GhcPs GhcPs body + -> UnexpectedStatement diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -20,7 +20,8 @@ emptyInert, addInertItem, - matchableGivens, + noMatchableGivenDicts, + noGivenNewtypeReprEqs, mightEqualLater, prohibitedSuperClassSolve, @@ -41,11 +42,11 @@ 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 @@ -53,6 +54,7 @@ import GHC.Core.Predicate import GHC.Core.TyCo.FVs import qualified GHC.Core.TyCo.Rep as Rep +import GHC.Core.Class( Class ) import GHC.Core.TyCon import GHC.Core.Unify @@ -338,7 +340,7 @@ in the above sense - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified + indeed, adding a "solved dictionary" when applying a quantified constraint led to the ability to define unsafeCoerce in #17267. @@ -883,7 +885,7 @@ (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t). It is always safe to extend S with such a triple. - (NB: we could strengten K1) in this way too, but see K3. + (NB: we could strengthen K1) in this way too, but see K3. - (K2b): if lhs not in s, we have no further opportunity to apply the work item @@ -1535,46 +1537,59 @@ -- becomes "outer" even though its level numbers says it isn't. | otherwise = False -- Coercion variables; doesn't much matter --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a +noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool +-- True <=> there is no Irred looking like (N tys1 ~ N tys2) +-- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Canonical +-- This is the only call site. +noGivenNewtypeReprEqs tc inerts + = not (anyBag might_help (inert_irreds (inert_cans inerts))) + where + might_help ct + = case classifyPredType (ctPred ct) of + EqPred ReprEq t1 t2 + | Just (tc1,_) <- tcSplitTyConApp_maybe t1 + , tc == tc1 + , Just (tc2,_) <- tcSplitTyConApp_maybe t2 + , tc == tc2 + -> True + _ -> False + +-- | Returns True iff there are no Given constraints that might, +-- potentially, match the given class consraint. This is used when checking to see if a -- Given might overlap with an instance. See Note [Instance and Given overlap] -- in "GHC.Tc.Solver.Interact" -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens +noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool +noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys + = not $ anyBag matchable_given $ + findDictsByClass (inert_dicts inert_cans) clas where - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans + pred_w = mkClassPred clas tys matchable_given :: Ct -> Bool matchable_given ct | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightEqualLater inerts pred_g loc_g pred_w loc_w + = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w | otherwise = False -mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst -- See Note [What might equal later?] -- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc | prohibitedSuperClassSolve given_loc wanted_loc - = False + = Nothing | otherwise = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of - SurelyApart -> False -- types that are surely apart do not equal later - MaybeApart MARInfinite _ -> False -- see Example 7 in the Note. - _ -> True + Unifiable subst + -> Just subst + MaybeApart reason subst + | MARInfinite <- reason -- see Example 7 in the Note. + -> Nothing + | otherwise + -> Just subst + SurelyApart -> Nothing where in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred] @@ -1621,7 +1636,7 @@ -- 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 @@ -1631,12 +1646,24 @@ = False can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance -prohibitedSuperClassSolve from_loc solve_loc - | InstSCOrigin _ given_size <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size +-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? +-- +-- Necessary (but not sufficient) conditions for this function to return @True@: +-- +-- - @ct1@ and @ct2@ both arise from superclass expansion, +-- - @ct1@ is a Given and @ct2@ is a Wanted. +-- +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2). +prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... + -> CtLoc -- ^ ... to solve this one? + -> Bool -- ^ True ==> don't solve it +prohibitedSuperClassSolve given_loc wanted_loc + | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc + , blocked + , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc + = True -- Prohibited if the Wanted is a superclass + -- and the Given has come via a superclass selection from + -- a predicate bigger than the head | otherwise = False diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs --- a/compiler/GHC/Tc/Solver/Types.hs +++ b/compiler/GHC/Tc/Solver/Types.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types ( -- Inert CDictCans diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -31,7 +31,7 @@ Env(..), TcGblEnv(..), TcLclEnv(..), setLclEnvTcLevel, getLclEnvTcLevel, - setLclEnvLoc, getLclEnvLoc, + setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode, IfGblEnv(..), IfLclEnv(..), tcVisibleOrphanMods, RewriteEnv(..), @@ -102,6 +102,7 @@ import GHC.Platform import GHC.Driver.Env +import GHC.Driver.Config.Core.Lint import GHC.Driver.Session import {-# SOURCE #-} GHC.Driver.Hooks @@ -183,7 +184,7 @@ -- 'ns_module_name' @A@, defines a mapping from @{A.T}@ -- (for some 'OccName' @T@) to some arbitrary other 'Name'. -- --- The most intruiging thing about a 'NameShape', however, is +-- The most intriguing thing about a 'NameShape', however, is -- how it's constructed. A 'NameShape' is *implied* by the -- exported 'AvailInfo's of the implementor of an interface: -- if an implementor of signature @\@ exports @M.T@, you implicitly @@ -293,6 +294,7 @@ -- ^ At what role are we rewriting? -- -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite + , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] } -- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined @@ -400,7 +402,7 @@ -- signatures (we just generate blank object files for -- hsig files.) -- --- A corrolary of this is that the following invariant holds at any point +-- A corollary of this is that the following invariant holds at any point -- past desugaring, -- -- if I have a Module, this_mod, in hand representing the module @@ -861,6 +863,9 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = tcl_in_gen_code + type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error @@ -973,7 +978,7 @@ -- | Get target platform -getPlatform :: TcM Platform +getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags --------------------------- @@ -1134,7 +1139,7 @@ | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group + -- tycons and classes in this recursive group -- The TyCon is always a TcTyCon. Its kind -- can be a mono-kind or a poly-kind; in TcTyClsDcls see -- Note [Type checking recursive type and class declarations] @@ -1147,25 +1152,6 @@ tcTyThingTyCon_maybe (ATcTyCon tc_tc) = Just tc_tc tcTyThingTyCon_maybe _ = Nothing -data PromotionErr - = TyConPE -- TyCon used in a kind before we are ready - -- data T :: T -> * where ... - | ClassPE -- Ditto Class - - | FamDataConPE -- Data constructor for a data family - -- See Note [AFamDataCon: not promoting data family constructors] - -- in GHC.Tc.Utils.Env. - | ConstrainedDataConPE PredType - -- Data constructor with a non-equality context - -- See Note [Don't promote data constructors with - -- non-equality contexts] in GHC.Tc.Gen.HsType - | PatSynPE -- Pattern synonyms - -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env - - | RecDataConPE -- Data constructor in a recursive loop - -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g ppr elt@(ATcId {}) = text "Identifier" <> @@ -1233,7 +1219,7 @@ - The fvs::RhsNames contains the free names of the RHS, excluding Global and ClosedLet ones. - - For the ClosedTypeId field see Note [Bindings with closed types] + - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId] For (static e) to be valid, we need for every 'x' free in 'e', that x's binding is floatable to the top level. Specifically: @@ -1350,16 +1336,6 @@ ppr (NonClosedLet fvs closed_type) = text "TopLevelLet" <+> ppr fvs <+> ppr closed_type -instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr PatSynPE = text "PatSynPE" - ppr FamDataConPE = text "FamDataConPE" - ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" - <+> parens (ppr pred) - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsDC = text "NoDataKindsDC" - -------------- pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory = text . capitalise . tcTyThingCategory @@ -1371,19 +1347,6 @@ tcTyThingCategory (ATcTyCon {}) = "local tycon" tcTyThingCategory (APromotionErr pe) = peCategory pe --------------- -pprPECategory :: PromotionErr -> SDoc -pprPECategory = text . capitalise . peCategory - -peCategory :: PromotionErr -> String -peCategory ClassPE = "class" -peCategory TyConPE = "type constructor" -peCategory PatSynPE = "pattern synonym" -peCategory FamDataConPE = "data constructor" -peCategory ConstrainedDataConPE{} = "data constructor" -peCategory RecDataConPE = "data constructor" -peCategory NoDataKindsDC = "data constructor" - {- ************************************************************************ * * @@ -1451,9 +1414,9 @@ imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, - imp_sig_mods = sig_mods1 `unionLists` sig_mods2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } + imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, + imp_orphs = unionListsOrd orphs1 orphs2, + imp_finsts = unionListsOrd finsts1 finsts2 } {- ************************************************************************ @@ -1860,7 +1823,8 @@ -- axioms, but should check other aspects, too. lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM () lintGblEnv logger dflags tcg_env = - liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms + -- TODO empty list means no extra in scope from GHCi, is this correct? + liftIO $ lintAxioms logger (initLintConfig dflags []) (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot --- a/compiler/GHC/Tc/Types.hs-boot +++ b/compiler/GHC/Tc/Types.hs-boot @@ -1,5 +1,6 @@ module GHC.Tc.Types where +import GHC.Prelude import GHC.Tc.Utils.TcType import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -11,8 +12,13 @@ data TcIdSigInfo instance Outputable TcIdSigInfo +data TcTyThing +instance Outputable TcTyThing + setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv getLclEnvTcLevel :: TcLclEnv -> TcLevel setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv getLclEnvLoc :: TcLclEnv -> RealSrcSpan + +lclEnvInGeneratedCode :: TcLclEnv -> Bool diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -3,8 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | This module defines types and simple operations over constraints, as used -- in the type-checker and constraint solver. module GHC.Tc.Types.Constraint ( @@ -126,6 +124,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) +import GHC.Types.Name.Reader import Data.Coerce import Data.Monoid ( Endo(..) ) @@ -200,17 +199,11 @@ cc_class :: Class, cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi - cc_pend_sc :: Bool, + cc_pend_sc :: Bool -- See Note [The superclass story] in GHC.Tc.Solver.Canonical -- True <=> (a) cc_class has superclasses -- (b) we have not (yet) added those -- superclasses as Givens - - cc_fundeps :: Bool - -- See Note [Fundeps with instances] in GHC.Tc.Solver.Interact - -- True <=> the class has fundeps, and we have not yet - -- compared this constraint with the global - -- instances for fundep improvement } | CIrredCan { -- These stand for yet-unusable predicates @@ -235,8 +228,9 @@ -- 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:N) If the equality is representational, rhs has no top-level newtype + -- * (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] -- in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is -- in scope.) @@ -314,7 +308,7 @@ -- signatures). See Note [Holes]. data Hole = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? - , hole_occ :: OccName -- ^ The name of this hole + , hole_occ :: RdrName -- ^ The name of this hole , hole_ty :: TcType -- ^ Type to be printed to the user -- For expression holes: type of expr -- For type holes: the missing type @@ -385,7 +379,7 @@ | ContainsCast TcType TcCoercionN -- | The type contains a forall. - | ContainsForall TyCoVarBinder TcType + | ContainsForall ForAllTyBinder TcType -- | The type contains a 'CoercionTy'. | ContainsCoercionTy TcCoercion @@ -678,10 +672,8 @@ pp_sort = case ct of CEqCan {} -> text "CEqCan" CNonCanonical {} -> text "CNonCanonical" - CDictCan { cc_pend_sc = psc, cc_fundeps = fds } - | psc, fds -> text "CDictCan(psc,fds)" - | psc, not fds -> text "CDictCan(psc)" - | not psc, fds -> text "CDictCan(fds)" + CDictCan { cc_pend_sc = psc } + | psc -> text "CDictCan(psc)" | otherwise -> text "CDictCan" CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason CQuantCan (QCI { qci_pend_sc = pend_sc }) @@ -694,7 +686,7 @@ -- 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 @@ -1242,7 +1234,7 @@ -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool -isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore occ) +isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e}) @@ -1411,7 +1403,7 @@ * LocalGivenEqs: definitely no Given equalities that would affect principal types. But may have equalities that affect only skolems of this implication - (and hence do not affect princial types) + (and hence do not affect principal types) Examples: forall a. F a ~ Int => ... forall a b. F a ~ G b => ... @@ -1564,7 +1556,7 @@ We assume NO SHADOWING in a constraint. Specifically * The unification variables are all implicitly quantified at top level, and are all unique - * The skolem variables bound in ic_skols are all freah when the + * The skolem variables bound in ic_skols are all fresh when the implication is created. So we can safely substitute. For example, if we have forall a. a~Int => ...(forall b. ...a...)... @@ -1698,7 +1690,7 @@ go (DerivSkol pred1) (DerivSkol pred2) = pred1 `tcEqType` pred2 go (TyConSkol f1 n1) (TyConSkol f2 n2) = f1==f2 && n1==n2 go (DataConSkol n1) (DataConSkol n2) = n1==n2 - go InstSkol InstSkol = True + go (InstSkol {}) (InstSkol {}) = True go FamInstSkol FamInstSkol = True go BracketSkol BracketSkol = True go (RuleSkol n1) (RuleSkol n2) = n1==n2 @@ -1708,7 +1700,6 @@ and (zipWith eq_pr ids1 ids2) go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 go ReifySkol ReifySkol = True - go QuantCtxtSkol QuantCtxtSkol = True go RuntimeUnkSkol RuntimeUnkSkol = True go ArrowReboundIfSkol ArrowReboundIfSkol = True go (UnkSkol _) (UnkSkol _) = True @@ -1724,7 +1715,7 @@ -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol - go FamInstSkol InstSkol = True + go FamInstSkol (InstSkol {}) = True -- In instance C (T a) where { type F (T a) b = ... } -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi -- SkolemInfo of FamInstSkol. Very like the ConDecl/TyConSkol case @@ -1899,7 +1890,7 @@ 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 @@ -1933,24 +1924,18 @@ -- 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 ppr (EvVarDest ev) = ppr ev @@ -2255,7 +2240,7 @@ it's actually quite easy to mistake one for another, in sufficiently involved scenarios, like ConstraintKinds.) -The flag -freduction-depth=n fixes the maximium level. +The flag -freduction-depth=n fixes the maximum level. * The counter includes the depth of type class instance declarations. Example: [W] d{7} : Eq [Int] diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -8,7 +8,7 @@ -- * HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, + mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, @@ -41,23 +41,7 @@ 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, - mkTcFamilyTyConAppCo, - isTcReflCo, isTcReflexiveCo, - tcCoercionRole, + maybeSymCo, unwrapIP, wrapIP, -- * QuoteWrapper @@ -69,6 +53,7 @@ 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 @@ -80,7 +65,6 @@ 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 @@ -117,99 +101,18 @@ -} -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 -mkTcFamilyTyConAppCo :: TyCon -> [TcCoercionN] -> TcCoercionN - -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 -mkTcFamilyTyConAppCo = mkFamilyTyConAppCo - -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 {- %************************************************************************ @@ -219,6 +122,8 @@ ************************************************************************ -} +-- We write wrap :: t1 ~> t2 +-- if wrap[ e::t1 ] :: t2 data HsWrapper = WpHole -- The identity coercion @@ -227,16 +132,24 @@ -- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) + -- + -- If wrap1 :: t2 ~> t3 + -- wrap2 :: t1 ~> t2 + --- Then (wrap1 `WpCompose` wrap2) :: t1 ~> t3 | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR) - -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ] - -- So note that if wrap1 :: exp_arg <= act_arg - -- wrap2 :: act_res <= exp_res - -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) + -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ] + -- So note that if e :: act_arg -> act_res + -- wrap1 :: exp_arg ~> act_arg + -- wrap2 :: act_res ~> exp_res + -- 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. | WpCast TcCoercionR -- A cast: [] `cast` co @@ -245,8 +158,11 @@ -- 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) @@ -291,29 +207,42 @@ 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 @@ -328,8 +257,8 @@ 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 @@ -442,7 +371,7 @@ Class constraints etc give rise to /term/ bindings for evidence, and we have nowhere to put term bindings in /types/. So in some places we use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level -evidence bindings are allowed. Notebly (): +evidence bindings are allowed. Notably (): - Places in types where we are solving kind constraints (all of which are equalities); see solveEqualities @@ -559,7 +488,7 @@ type EvExpr = CoreExpr -- An EvTerm is (usually) constructed by any of the constructors here --- and those more complicates ones who were moved to module GHC.Tc.Types.EvTerm +-- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm -- | Any sort of evidence Id, including coercions evId :: EvId -> EvExpr @@ -665,7 +594,7 @@ dl :: Typeable [a] = EvTypeable [a] (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) where - d :: Typable a + d :: Typeable a is the lambda-bound dictionary passed into f. Note [Coercion evidence terms] @@ -851,10 +780,10 @@ 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 @@ -1032,10 +961,12 @@ = 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 (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/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -3,9 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( @@ -16,7 +13,7 @@ -- * SkolemInfo SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, - unkSkol, unkSkolAnon, + unkSkol, unkSkolAnon, mkClsInstSkol, -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, @@ -31,7 +28,8 @@ -- * FixedRuntimeRep origin FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..), pprFixedRuntimeRepContext, - StmtOrigin(..), + StmtOrigin(..), RepPolyFun(..), ArgPos(..), + ClsInstOrQC(..), NakedScFlag(..), -- * Arrow command origin FRRArrowContext(..), pprFRRArrowContext, @@ -48,6 +46,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon +import GHC.Core.Class import GHC.Core.InstEnv import GHC.Core.PatSyn import GHC.Core.Multiplicity ( scaledThing ) @@ -68,6 +67,8 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + {- ********************************************************************* * * UserTypeCtxt @@ -211,8 +212,9 @@ -- same place in a single report. data SkolemInfo = SkolemInfo - Unique -- ^ used to common up skolem variables bound at the same location (only used in pprSkols) - SkolemInfoAnon -- ^ the information about the origin of the skolem type variable + Unique -- ^ The Unique is used to common up skolem variables bound + -- at the same location (only used in pprSkols) + SkolemInfoAnon -- ^ The information about the origin of the skolem type variable instance Uniquable SkolemInfo where getUnique (SkolemInfo u _) = u @@ -249,7 +251,9 @@ | DerivSkol Type -- Bound by a 'deriving' clause; -- the type is the instance we are trying to derive - | InstSkol -- Bound at an instance decl + | InstSkol -- Bound at an instance decl, or quantified constraint + ClsInstOrQC -- Whether class instance or quantified constraint + PatersonSize -- Head has the given PatersonSize | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for @@ -265,7 +269,7 @@ | RuleSkol RuleName -- The LHS of a RULE | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually-recursivive) + -- We have inferred a type for these (mutually recursive) -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. @@ -281,9 +285,6 @@ | ReifySkol -- Bound during Template Haskell reification - | QuantCtxtSkol -- Quantified context, e.g. - -- f :: forall c. (forall a. c a => c [a]) => blah - | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 | ArrowReboundIfSkol -- Bound by the expected type of the rebound arrow ifThenElse command. @@ -313,6 +314,8 @@ getSkolemInfo :: SkolemInfo -> SkolemInfoAnon getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon +mkClsInstSkol :: Class -> [Type] -> SkolemInfoAnon +mkClsInstSkol cls tys = InstSkol IsClsInst (pSizeClassPred cls tys) instance Outputable SkolemInfo where ppr (SkolemInfo _ sk_info ) = ppr sk_info @@ -328,7 +331,10 @@ pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) -pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSkol IsClsInst sz) = vcat [ text "the instance declaration" + , whenPprDebug (braces (ppr sz)) ] +pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context" + , whenPprDebug (braces (ppr sz)) ] pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name @@ -342,7 +348,6 @@ pprSkolInfo (DataConSkol name) = text "the type signature for" <+> quotes (ppr name) pprSkolInfo ReifySkol = text "the type being reified" -pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command" @@ -451,40 +456,26 @@ -- 'SkolemInfo' inside gives more information. GivenOrigin SkolemInfoAnon - -- The following are other origins for given constraints that cannot produce - -- new skolems -- hence no SkolemInfo. - - -- | 'InstSCOrigin' is used for a Given constraint obtained by superclass selection + -- | 'GivenSCOrigin' is used for a Given constraint obtained by superclass selection -- from the context of an instance declaration. E.g. -- instance @(Foo a, Bar a) => C [a]@ where ... -- When typechecking the instance decl itself, including producing evidence -- for the superclasses of @C@, the superclasses of @(Foo a)@ and @(Bar a)@ will - -- have 'InstSCOrigin' origin. - | InstSCOrigin ScDepth -- ^ The number of superclass selections necessary to - -- get this constraint; see Note [Replacement vs keeping] - -- and Note [Use only the best local instance], both in - -- GHC.Tc.Solver.Interact - TypeSize -- ^ If @(C ty1 .. tyn)@ is the largest class from - -- which we made a superclass selection in the chain, - -- then @TypeSize = sizeTypes [ty1, .., tyn]@ - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- have 'GivenSCOrigin' origin. + | GivenSCOrigin + SkolemInfoAnon -- ^ Just like GivenOrigin - -- | 'OtherSCOrigin' is used for a Given constraint obtained by superclass - -- selection from a constraint /other than/ the context of an instance - -- declaration. (For the latter we use 'InstSCOrigin'.) E.g. - -- f :: Foo a => blah - -- f = e - -- When typechecking body of 'f', the superclasses of the Given (Foo a) - -- will have 'OtherSCOrigin'. - -- Needed for Note [Replacement vs keeping] and - -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact. - | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to - -- get this constraint - SkolemInfoAnon -- ^ Where the sub-class constraint arose from - -- (used only for printing) + ScDepth -- ^ The number of superclass selections necessary to + -- get this constraint; see Note [Replacement vs keeping] + -- in GHC.Tc.Solver.Interact - -- All the others are for *wanted* constraints + Bool -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds + -- i.e. ones with (ScOrigin _ NakedSc) + -- False => can use this to solve all Wanted constraints + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + ----------- Below here, all are Origins for Wanted constraints ------------ + | OccurrenceOf Name -- Occurrence of an overloaded identifier | OccurrenceOfRecSel RdrName -- Occurrence of a record selector | AppOrigin -- An application of some kind @@ -532,11 +523,10 @@ | ViewPatOrigin -- | 'ScOrigin' is used only for the Wanted constraints for the - -- superclasses of an instance declaration. - -- If the instance head is @C ty1 .. tyn@ - -- then @TypeSize = sizeTypes [ty1, .., tyn]@ - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - | ScOrigin TypeSize + -- superclasses of an instance declaration. + | ScOrigin + ClsInstOrQC -- Whether class instance or quantified constraint + NakedScFlag | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to -- standalone deriving). @@ -581,7 +571,7 @@ PredType CtOrigin RealSrcSpan -- This constraint arising from ... PredType CtOrigin RealSrcSpan -- and this constraint arising from ... - | ExprHoleOrigin (Maybe OccName) -- from an expression hole + | ExprHoleOrigin (Maybe RdrName) -- from an expression hole | TypeHoleOrigin OccName -- from a type hole (partial type signature) | PatCheckOrigin -- normalisation of a type during pattern-match checking | ListOrigin -- An overloaded list @@ -605,6 +595,7 @@ | CycleBreakerOrigin CtOrigin -- origin of the original constraint + -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical | FRROrigin FixedRuntimeRepOrigin @@ -620,11 +611,25 @@ Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt + -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. type ScDepth = Int +data ClsInstOrQC = IsClsInst + | IsQC CtOrigin + +data NakedScFlag = NakedSc | NotNakedSc + -- The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve + -- * For the original superclass constraints we use (ScOrigin _ NakedSc) + -- * But after using an instance declaration we use (ScOrigin _ NotNakedSc) + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + +instance Outputable NakedScFlag where + ppr NakedSc = text "NakedSc" + ppr NotNakedSc = text "NotNakedSc" + -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of @@ -641,11 +646,10 @@ toInvisibleOrigin orig = orig isGivenOrigin :: CtOrigin -> Bool -isGivenOrigin (GivenOrigin {}) = True -isGivenOrigin (InstSCOrigin {}) = True -isGivenOrigin (OtherSCOrigin {}) = True -isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o -isGivenOrigin _ = False +isGivenOrigin (GivenOrigin {}) = True +isGivenOrigin (GivenSCOrigin {}) = True +isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o +isGivenOrigin _ = False -- See Note [Suppressing confusing errors] in GHC.Tc.Errors isWantedWantedFunDepOrigin :: CtOrigin -> Bool @@ -673,10 +677,10 @@ exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f) +exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsRecSel _ f) = OccurrenceOfRecSel (unLoc $ foLabel f) -exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l +exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit @@ -684,7 +688,7 @@ exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches exprCtOrigin (HsLamCase _ _ ms) = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1 _ _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ _ e _) = lexprCtOrigin e @@ -705,7 +709,8 @@ exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" +exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a @@ -731,10 +736,13 @@ pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..." -pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk -pprCtOrigin (InstSCOrigin {}) = ctoHerald <+> pprSkolInfo InstSkol -- keep output in sync -pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si +pprCtOrigin (GivenOrigin sk) + = ctoHerald <+> ppr sk +pprCtOrigin (GivenSCOrigin sk d blk) + = vcat [ ctoHerald <+> pprSkolInfo sk + , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] + pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of FunSigCtxt n _ -> text "for" <+> quotes (ppr n) @@ -817,9 +825,6 @@ pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig -pprCtOrigin (FRROrigin {}) - = ctoHerald <+> text "a representation-polymorphism check" - pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig) = sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma , pprCtOrigin subclass_orig ] @@ -836,6 +841,15 @@ = ctoHerald <+> text "a type ambiguity check for" $$ pprUserTypeCtxt ctxt +pprCtOrigin (ScOrigin IsClsInst nkd) + = vcat [ ctoHerald <+> text "the superclasses of an instance declaration" + , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) ] + +pprCtOrigin (ScOrigin (IsQC orig) nkd) + = vcat [ ctoHerald <+> text "the head of a quantified constraint" + , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) + , pprCtOrigin orig ] + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin @@ -859,8 +873,8 @@ pprCtO AssocFamPatOrigin = text "the LHS of a family instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> whenPprDebug (parens (ppr n)) +pprCtO (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration" +pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" @@ -884,8 +898,7 @@ -- get here via callStackOriginFS, when doing ambiguity checks -- A bit silly, but no great harm pprCtO (GivenOrigin {}) = text "a given constraint" -pprCtO (InstSCOrigin {}) = text "the superclass of an instance constraint" -pprCtO (OtherSCOrigin {}) = text "the superclass of a given constraint" +pprCtO (GivenSCOrigin {}) = text "the superclass of a given constraint" pprCtO (SpecPragOrigin {}) = text "a SPECIALISE pragma" pprCtO (FunDepOrigin1 {}) = text "a functional dependency" pprCtO (FunDepOrigin2 {}) = text "a functional dependency" @@ -990,10 +1003,14 @@ -- 'FixedRuntimeRepOrigin' for that. data FixedRuntimeRepContext + -- | Record fields in record construction must have a fixed runtime + -- representation. + = FRRRecordCon !RdrName !(HsExpr GhcTc) + -- | Record fields in record updates must have a fixed runtime representation. -- -- Test case: RepPolyRecordUpdate. - = FRRRecordUpdate !RdrName !(HsExpr GhcTc) + | FRRRecordUpdate !Name !(HsExpr GhcRn) -- | Variable binders must have a fixed runtime representation. -- @@ -1016,21 +1033,17 @@ -- Test cases: RepPolyCase{1,2}. | FRRCase - -- | An instantiation of a newtype/data constructor in which + -- | An instantiation of a newtype/data constructor pattern in which -- an argument type does not have a fixed runtime representation. -- - -- The argument can either be an expression or a pattern. - -- - -- Test cases: - -- Expression: UnliftedNewtypesLevityBinder. - -- Pattern: T20363. - | FRRDataConArg !ExprOrPat !DataCon !Int + -- Test case: T20363. + | FRRDataConPatArg !DataCon !Int - -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`) + -- | An instantiation of a function with no binding (e.g. `coerce`, `unsafeCoerce#`, an unboxed tuple 'DataCon') -- in which one of the remaining arguments types does not have a fixed runtime representation. -- - -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesCoerceFail. - | FRRNoBindingResArg !Id !Int + -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRNoBindingResArg !RepPolyFun !ArgPos -- | Arguments to unboxed tuples must have fixed runtime representations. -- @@ -1053,7 +1066,7 @@ -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody. | FRRBodyStmt !StmtOrigin !Int - -- | Arguments to a guard in a monad comprehesion must have + -- | Arguments to a guard in a monad comprehension must have -- a fixed runtime representation. -- -- Test case: RepPolyMcGuard. @@ -1090,6 +1103,9 @@ -- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin' -- and is reported separately. pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc +pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) + = sep [ text "The field", quotes (ppr lbl) + , text "of the record constructor" ] pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) = sep [ text "The record update at field" , quotes (ppr lbl) ] @@ -1102,21 +1118,33 @@ = text "The pattern synonym argument pattern" pprFixedRuntimeRepContext FRRCase = text "The scrutinee of the case statement" -pprFixedRuntimeRepContext (FRRDataConArg expr_or_pat con i) +pprFixedRuntimeRepContext (FRRDataConPatArg con i) = text "The" <+> what where - arg, what :: SDoc - arg = case expr_or_pat of - Expression -> text "argument" - Pattern -> text "pattern" + what :: SDoc what | isNewDataCon con - = text "newtype constructor" <+> arg + = text "newtype constructor pattern" | otherwise - = text "data constructor" <+> arg <+> text "in" <+> speakNth i <+> text "position" -pprFixedRuntimeRepContext (FRRNoBindingResArg fn i) - = vcat [ text "Unsaturated use of a representation-polymorphic primitive function." - , text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn) ] + = text "data constructor pattern in" <+> speakNth i <+> text "position" +pprFixedRuntimeRepContext (FRRNoBindingResArg fn arg_pos) + = vcat [ text "Unsaturated use of a representation-polymorphic" <+> what_fun <> dot + , what_arg <+> text "argument of" <+> quotes (ppr fn) ] + where + what_fun, what_arg :: SDoc + what_fun = case fn of + RepPolyWiredIn {} -> text "primitive function" + RepPolyDataCon dc -> what_con <+> text "constructor" + where + what_con :: SDoc + what_con + | isNewDataCon dc + = text "newtype" + | otherwise + = text "data" + what_arg = case arg_pos of + ArgPosInvis -> text "An invisible" + ArgPosVis i -> text "The" <+> speakNth i pprFixedRuntimeRepContext (FRRTupleArg i) = text "The tuple argument in" <+> speakNth i <+> text "position" pprFixedRuntimeRepContext (FRRTupleSection i) @@ -1152,6 +1180,30 @@ instance Outputable StmtOrigin where ppr MonadComprehension = text "monad comprehension" ppr DoNotation = quotes ( text "do" ) <+> text "statement" + +-- | A function with representation-polymorphic arguments, +-- such as @coerce@ or @(#, #)@. +-- +-- Used for reporting partial applications of representation-polymorphic +-- functions in error messages. +data RepPolyFun + = RepPolyWiredIn !Id + -- ^ A wired-in function with representation-polymorphic + -- arguments, such as 'coerce'. + | RepPolyDataCon !DataCon + -- ^ A data constructor with representation-polymorphic arguments, + -- such as an unboxed tuple or a newtype constructor with @-XUnliftedNewtypes@. + +instance Outputable RepPolyFun where + ppr (RepPolyWiredIn id) = ppr id + ppr (RepPolyDataCon dc) = ppr dc + +-- | The position of an argument (to be reported in an error message). +data ArgPos + = ArgPosInvis + -- ^ Invisible argument: don't report its position to the user. + | ArgPosVis !Int + -- ^ Visible argument in i-th position. {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot --- a/compiler/GHC/Tc/Types/Origin.hs-boot +++ b/compiler/GHC/Tc/Types/Origin.hs-boot @@ -7,4 +7,8 @@ data FixedRuntimeRepContext data FixedRuntimeRepOrigin +data CtOrigin +data ClsInstOrQC = IsClsInst + | IsQC CtOrigin + unkSkol :: HasCallStack => SkolemInfo diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -1,10 +1,8 @@ - +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -36,10 +34,12 @@ SyntaxOpType(..), synKnownType, mkSynFunTys, + -------------------------------- -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, deeperThanOrSame, sameDepthAs, tcTypeLevel, tcTyVarLevel, maxTcLevel, + -------------------------------- -- MetaDetails TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk, @@ -56,13 +56,12 @@ -------------------------------- -- 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 +71,28 @@ 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 @@ -130,43 +131,54 @@ isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type + --------------------------------- + -- Patersons sizes + PatersonSize(..), PatersonSizeFailure(..), + ltPatersonSize, + pSizeZero, pSizeOne, + pSizeType, pSizeTypeX, pSizeTypes, + pSizeClassPred, pSizeClassPredX, + pSizeTyConApp, + noMoreTyVars, allDistinctTyVars, + TypeSize, sizeType, sizeTypes, scopedSort, + isTerminatingClass, isStuckTypeFamily, + -------------------------------- -- 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, isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass, mkClassPred, - tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, + tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, - isVisibleBinder, isInvisibleBinder, + isVisiblePiTyBinder, isInvisiblePiTyBinder, -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + Subst(..), -- Representation visible to a few friends + TvSubstEnv, emptySubst, mkEmptySubst, zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, + mkTvSubstPrs, notElemSubst, unionSubst, + getTvSubstEnv, getSubstInScope, extendSubstInScope, + extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, @@ -175,11 +187,11 @@ substCoUnchecked, substCoWithUnchecked, substTheta, - isUnliftedType, -- Source types are always lifted - isUnboxedTupleType, -- Ditto + isUnliftedType, + isUnboxedTupleType, isPrimitiveType, - tcView, coreView, + coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, tyCoFVsOfType, tyCoFVsOfTypes, @@ -193,8 +205,6 @@ pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTCvBndr, pprTCvBndrs, - TypeSize, sizeType, sizeTypes, scopedSort, - --------------------------------- -- argument visibility tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible @@ -206,6 +216,7 @@ 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 +240,6 @@ -- 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 ) @@ -245,8 +255,9 @@ import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) -import Data.List ( partition ) +import Data.List ( partition, nub, (\\) ) +import GHC.Generics ( Generic ) {- ************************************************************************ @@ -328,7 +339,7 @@ of Var.Var. The "tc" prefix means "a type variable that can be encountered by the typechecker". -This is a bit of a change from an earlier era when we remoselessly +This is a bit of a change from an earlier era when we remorselessly insisted on real TcTyVars in the type checker. But that seems unnecessary (for skolems, TyVars are fine) and it's now very hard to guarantee, with the advent of kind equalities. @@ -427,7 +438,7 @@ - Flag tcTyConIsPoly = True; this is used only to short-cut zonking - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, - with fixed kinds: no unification variables here + with fixed kinds, and accurate skolem info: no unification variables here tyConBinders includes the Inferred binders if any @@ -583,15 +594,34 @@ (historically but still there) Var.tcTyVarDetails returns vanillaSkolemTv for a TyVar. -But ultimately I want to seeparate Type from TcType, and in that case +But ultimately I want to separate Type from TcType, and in that case we would need to enforce the separation. + +Note [Keeping SkolemInfo inside a SkolemTv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A SkolemTv contains a SkolemInfo, which describes the binding side of that +TcTyVar. This is very convenient to a consumer of a SkolemTv, but it is +a bit awkward for the /producer/. Why? Because sometimes we can't produce +the SkolemInfo until we have the TcTyVars! + +Example: in `GHC.Tc.Utils.Unify.tcTopSkolemise` we create SkolemTvs whose +`SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created +SkolemTvs. So we a RecrusiveDo idiom, like this: + + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + +Note that the `skol_info` can't be created until we have the `tv_prs` returned +by `skolemise`. Note also that `skolemise` had better be lazy in `skol_info`. + +All uses of this idiom should be flagged with a reference to this Note. -} -- A TyVarDetails is inside a TyVar --- See Note [TyVars and TcTyVars] +-- See Note [TyVars and TcTyVars during type checking] data TcTyVarDetails = SkolemTv -- A skolem - SkolemInfo + SkolemInfo -- See Note [Keeping SkolemInfo inside a SkolemTv] TcLevel -- Level of the implication that binds it -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for -- how this level number is used @@ -764,7 +794,7 @@ (forall[3] b. alpha[3] ~ b) We can unify alpha:=b in the inner implication, because 'alpha' is -touchable; but then 'b' has excaped its scope into the outer implication. +touchable; but then 'b' has escaped its scope into the outer implication. -} maxTcLevel :: TcLevel -> TcLevel -> TcLevel @@ -882,7 +912,7 @@ 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 @@ -897,9 +927,9 @@ ++ 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, @@ -953,7 +983,7 @@ 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 @@ -975,7 +1005,7 @@ go_tc NomEq bvs _ tys = any (go NomEq bvs) tys go_tc ReprEq bvs tc tys = any (go_arg bvs) - (tyConRolesRepresentational tc `zip` tys) + (tyConRoleListRepresentational tc `zip` tys) go_arg bvs (Nominal, ty) = go NomEq bvs ty go_arg bvs (Representational, ty) = go ReprEq bvs ty @@ -1042,7 +1072,7 @@ 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 @@ -1058,7 +1088,7 @@ (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 {- @@ -1279,22 +1309,39 @@ ************************************************************************ -} -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 -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTysMany +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 :: 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 -- construct a dictionary function name @@ -1303,7 +1350,7 @@ 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) @@ -1313,58 +1360,34 @@ 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 @@ -1378,13 +1401,13 @@ -- | 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 @@ -1396,32 +1419,26 @@ -- | 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 @@ -1456,7 +1473,7 @@ , (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) @@ -1497,26 +1514,16 @@ -- | 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 @@ -1526,12 +1533,13 @@ (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: @@ -1562,7 +1570,7 @@ 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) @@ -1577,8 +1585,8 @@ ----------------------- 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 @@ -1593,34 +1601,9 @@ 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 @@ -1628,21 +1611,24 @@ tcIsTyVarTy _ = False ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) --- Split the type of a dictionary function --- We don't use tcSplitSigmaTy, because a DFun may (with NDP) --- have non-Pred arguments, such as --- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m --- --- Also NB splitFunTys, not tcSplitFunTys; +tcSplitQuantPredTy :: Type -> ([TyVar], [Type], PredType) +-- Split up the type of a quantified predicate +-- forall tys, theta => head +-- NB splitFunTys, not tcSplitFunTys; -- the latter specifically stops at PredTy arguments, -- and we don't want to do that here -tcSplitDFunTy ty +tcSplitQuantPredTy ty = case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, map scaledThing theta, clas, tys) }}} + case splitFunTys rho of { (theta, head) -> + (tvs, map scaledThing theta, head) }} +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +tcSplitDFunTy ty + = case tcSplitQuantPredTy ty of { (tvs, theta, head) -> + case tcSplitDFunHead head of { (clas, tys) -> + (tvs, theta, clas, tys) }} + tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead = getClassPredTys @@ -1667,178 +1653,6 @@ {- ********************************************************************* * * - 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 * * ************************************************************************ @@ -1864,8 +1678,8 @@ -- If the Bool is True (flexible contexts), return True (i.e. ok) -- Otherwise, check that the type (not kind) args are all headed by a tyvar -- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected --- This function is here rather than in GHC.Tc.Validity because it is --- called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity +-- This function is here in GHC.Tc.Utils.TcType, rather than in GHC.Tc.Validity, +-- because it is called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity checkValidClsArgs flexible_contexts cls kts | flexible_contexts = True | otherwise = all hasTyVarHead tys @@ -1900,12 +1714,12 @@ NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) - | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible + | otherwise -> Nothing -- Sigh: we do not have heterogeneous Coercible -- 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 @@ -2076,15 +1890,15 @@ -- 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 @@ -2095,16 +1909,16 @@ 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, isFloatPrimTy, isDoublePrimTy, isIntegerTy, isNaturalTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy, isAnyTy :: Type -> Bool + isUnitTy, isCharTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isFloatPrimTy = is_tc floatPrimTyConKey @@ -2116,8 +1930,17 @@ isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey -isAnyTy = is_tc anyTyConKey +-- | Check whether the type is of the form @Any :: k@, +-- returning the kind @k@. +anyTy_maybe :: Type -> Maybe Kind +anyTy_maybe ty + | Just (tc, [k]) <- splitTyConApp_maybe ty + , getUnique tc == anyTyConKey + = Just k + | otherwise + = Nothing + -- | Is the type inhabited by machine floating-point numbers? -- -- Used to check that we don't use floating-point literal patterns @@ -2186,7 +2009,7 @@ visible type application. Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. +in PiTyVarBinder. -} @@ -2236,6 +2059,7 @@ | LinearTypesNotAllowed | OneArgExpected | AtLeastOneArgExpected + deriving Generic -- | Reason why a type cannot be marshalled through the FFI. data TypeCannotBeMarshaledReason @@ -2245,6 +2069,8 @@ | NotABoxedMarshalableTyCon | ForeignLabelNotAPtr | NotSimpleUnliftedType + | NotBoxedKindAny + deriving Generic isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import' @@ -2287,22 +2113,44 @@ | otherwise = NotValid ForeignLabelNotAPtr +-- | Check validity for a type of the form @Any :: k@. +-- +-- This function returns: +-- +-- - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@, +-- - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types, +-- - @Nothing@ if the type is not @Any@. +checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason) +checkAnyTy ty + | Just ki <- anyTy_maybe ty + = Just $ + if isJust $ kindBoxedRepLevity_maybe ki + then IsValid + -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305. + else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny) + | otherwise + = Nothing + isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types, or the well-known type --- Any, which can be used to pass the address to a Haskell object on the heap to +-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType), +-- which can be used to pass the address to a Haskell object on the heap to -- the foreign function. isFFIPrimArgumentTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid result type for a 'foreign import prim' Currently -- it must be an unlifted type, including unboxed tuples, unboxed --- sums, or the well-known type Any. +-- sums, or the well-known type Any (at kind Type or UnliftedType). isFFIPrimResultTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty isFunPtrTy :: Type -> Bool isFunPtrTy ty @@ -2446,71 +2294,11 @@ {- ************************************************************************ * * - The "Paterson size" of a type + Visiblities * * ************************************************************************ -} -{- -Note [Paterson conditions on PredTypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are considering whether *class* constraints terminate -(see Note [Paterson conditions]). Precisely, the Paterson conditions -would have us check that "the constraint has fewer constructors and variables -(taken together and counting repetitions) than the head.". - -However, we can be a bit more refined by looking at which kind of constraint -this actually is. There are two main tricks: - - 1. It seems like it should be OK not to count the tuple type constructor - for a PredType like (Show a, Eq a) :: Constraint, since we don't - count the "implicit" tuple in the ThetaType itself. - - In fact, the Paterson test just checks *each component* of the top level - ThetaType against the size bound, one at a time. By analogy, it should be - OK to return the size of the *largest* tuple component as the size of the - whole tuple. - - 2. Once we get into an implicit parameter or equality we - can't get back to a class constraint, so it's safe - to say "size 0". See #4200. - -NB: we don't want to detect PredTypes in sizeType (and then call -sizePred on them), or we might get an infinite loop if that PredType -is irreducible. See #5581. --} - -type TypeSize = IntWithInf - -sizeType :: Type -> TypeSize --- Size of a type: the number of variables and constructors --- Ignore kinds altogether -sizeType = go - where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 - go (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 - -- Why filter out invisible args? I suppose any - -- size ordering is sound, but why is this better? - -- I came across this when investigating #14010. - go (LitTy {}) = 1 - 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 - -sizeTypes :: [Type] -> TypeSize -sizeTypes tys = sum (map sizeType tys) - ------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------ ------------------------ -- | For every arg a tycon can take, the returned list says True if the argument -- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to -- allow for oversaturation. @@ -2518,7 +2306,7 @@ 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 @@ -2528,7 +2316,235 @@ -- | 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 + +{- +************************************************************************ +* * + Paterson sizes +* * +************************************************************************ +-} + +{- Note [The PatersonSize of a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The PatersonSize of type is something we can compare, with `ltPatersonSize`, +to determine if the Paterson conditions are satisfied for an instance +declaration. See Note [Paterson conditions] in GHC.Tc.Validity. + +There are some wrinkles + +(PS1) Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See #4200. + + We do this with isTerminatingClass + +Note [Invisible arguments and termination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the ​Paterson conditions for termination an instance +declaration, we check for the number of "constructors and variables" +in the instance head and constraints. Question: Do we look at + + * All the arguments, visible or invisible? + * Just the visible arguments? + +I think both will ensure termination, provided we are consistent. +Currently we are /not/ consistent, which is really a bug. It's +described in #15177, which contains a number of examples. +The suspicious bits are the calls to filterOutInvisibleTypes. +See also #11833. + +Note [Stuck type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type-family application generally has infinite size (PS_TyFam); +see (PC3) in Note [Paterson conditions] in GHC.Tc.Validity. + +But a couple of built-in type families have no axioms, and can never +expand into anything else. They are: + +* (TypeError "stuff"). E.g. consider + + type family F a where + F Int = Bool + F Bool = Char + F _ = TypeError "Bad" + + We don't want to complain about possible non-termination of F, in + GHC.Tc.Validity.checkFamInstRhs. cf indexed-types/should_fail/T13271 + +* (Any @k). + +For now we treat them as being size zero, but (#22696) I think we should +actually treat them as big (like any other ype family) because we don't +want to abstract over them in e.g. validDerivPred. + +The type-family termination test, in GHC.Tc.Validity.checkFamInstRhs, already +has a separate call to isStuckTypeFamily, so the `F` above will still be accepted. +-} + + +data PatersonSizeFailure + = PSF_TyFam TyCon -- Type family + | PSF_Size -- Too many type constructors/variables + | PSF_TyVar [TyVar] -- These type variables appear more often than in instance head; + -- no duplicates in this list + +-------------------------------------- + +data PatersonSize -- See Note [Paterson conditions] in GHC.Tc.Validity + = PS_TyFam TyCon -- Mentions a type family; infinite size + + | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions; + , ps_size :: Int -- Number of type constructors and variables + } + -- Always after expanding synonyms + -- Always ignore coercions (not user written) + -- ToDo: ignore invisible arguments? See Note [Invisible arguments and termination] + +instance Outputable PatersonSize where + ppr (PS_TyFam tc) = text "PS_TyFam" <+> ppr tc + ppr (PS_Vanilla { ps_tvs = tvs, ps_size = size }) + = text "PS_Vanilla" <> braces (sep [ text "ps_tvs =" <+> ppr tvs <> comma + , text "ps_size =" <+> int size ]) + +pSizeZero, pSizeOne :: PatersonSize +pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 } +pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 } + +ltPatersonSize :: PatersonSize -- Size of constraint + -> PatersonSize -- Size of instance head; never PS_TyFam + -> Maybe PatersonSizeFailure +-- (ps1 `ltPatersonSize` ps2) returns +-- Nothing iff ps1 is strictly smaller than p2 +-- Just ps_fail says what went wrong +ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc) +ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) + (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) + | s1 >= s2 = Just PSF_Size + | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs) + | otherwise = Nothing -- OK! +ltPatersonSize (PS_Vanilla {}) (PS_TyFam tc) + = pprPanic "ltPSize" (ppr tc) + -- Impossible because we never have a type family in an instance head + +noMoreTyVars :: [TyVar] -- Free vars (with repetitions) of the constraint C + -> [TyVar] -- Free vars (with repetitions) of the head H + -> [TyVar] -- TyVars that appear more often in C than H; + -- no repetitions in this list +noMoreTyVars tvs head_tvs + = nub (tvs \\ head_tvs) -- The (\\) is list difference; e.g. + -- [a,b,a,a] \\ [a,a] = [b,a] + -- So we are counting repetitions + +addPSize :: PatersonSize -> PatersonSize -> PatersonSize +addPSize ps1@(PS_TyFam {}) _ = ps1 +addPSize _ ps2@(PS_TyFam {}) = ps2 +addPSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) + (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) + = PS_Vanilla { ps_tvs = tvs1 ++ tvs2, ps_size = s1 + s2 } + -- (++) is not very performant, but the types + -- are user-written and never large + +pSizeType :: Type -> PatersonSize +pSizeType = pSizeTypeX emptyVarSet + +pSizeTypes :: [Type] -> PatersonSize +pSizeTypes = pSizeTypesX emptyVarSet pSizeZero + +-- Paterson size of a type, retaining repetitions, and expanding synonyms +-- This ignores coercions, as coercions aren't user-written +pSizeTypeX :: VarSet -> Type -> PatersonSize +pSizeTypeX bvs ty | Just exp_ty <- coreView ty = pSizeTypeX bvs exp_ty +pSizeTypeX bvs (TyVarTy tv) + | tv `elemVarSet` bvs = pSizeOne + | otherwise = PS_Vanilla { ps_tvs = [tv], ps_size = 1 } +pSizeTypeX _ (LitTy {}) = pSizeOne +pSizeTypeX bvs (TyConApp tc tys) = pSizeTyConAppX bvs tc tys +pSizeTypeX bvs (AppTy fun arg) = pSizeTypeX bvs fun `addPSize` pSizeTypeX bvs arg +pSizeTypeX bvs (FunTy _ w arg res) = pSizeTypeX bvs w `addPSize` pSizeTypeX bvs arg `addPSize` + pSizeTypeX bvs res +pSizeTypeX bvs (ForAllTy (Bndr tv _) ty) = pSizeTypeX bvs (tyVarKind tv) `addPSize` + pSizeTypeX (bvs `extendVarSet` tv) ty +pSizeTypeX bvs (CastTy ty _) = pSizeTypeX bvs ty +pSizeTypeX _ (CoercionTy {}) = pSizeOne + +pSizeTypesX :: VarSet -> PatersonSize -> [Type] -> PatersonSize +pSizeTypesX bvs sz tys = foldr (addPSize . pSizeTypeX bvs) sz tys + +pSizeTyConApp :: TyCon -> [Type] -> PatersonSize +pSizeTyConApp = pSizeTyConAppX emptyVarSet + +pSizeTyConAppX :: VarSet -> TyCon -> [Type] -> PatersonSize +-- Open question: do we count all args, or just the visible ones? +-- See Note [Invisible arguments and termination] +pSizeTyConAppX bvs tc tys + | isTypeFamilyTyCon tc = pSizeTyFamApp tc + | otherwise = pSizeTypesX bvs pSizeOne tys + +pSizeTyFamApp :: TyCon -> PatersonSize +-- See Note [Stuck type families] +pSizeTyFamApp tc + | isStuckTypeFamily tc = pSizeZero + | otherwise = PS_TyFam tc + +pSizeClassPred :: Class -> [Type] -> PatersonSize +pSizeClassPred = pSizeClassPredX emptyVarSet + +pSizeClassPredX :: VarSet -> Class -> [Type] -> PatersonSize +pSizeClassPredX bvs cls tys + | isTerminatingClass cls -- See (PS1) in Note [The PatersonSize of a type] + = pSizeZero + | otherwise + = pSizeTypesX bvs pSizeOne $ + filterOutInvisibleTypes (classTyCon cls) tys + -- filterOutInvisibleTypes Yuk! See Note [Invisible arguments and termination] + +isStuckTypeFamily :: TyCon -> Bool +-- See Note [Stuck type families] +isStuckTypeFamily tc + = tc `hasKey` errorMessageTypeErrorFamKey + || tc `hasKey` anyTyConKey + +-- | When this says "True", ignore this class constraint during +-- a termination check +-- See (PS1) in Note [The PatersonSize of a type] +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = isIPClass cls -- Implicit parameter constraints always terminate because + -- there are no instances for them --- they are only solved + -- by "local instances" in expressions + || isEqPredClass cls + || cls `hasKey` typeableClassKey + -- Typeable constraints are bigger than they appear due + -- to kind polymorphism, but we can never get instance divergence this way + || cls `hasKey` coercibleTyConKey + +allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool +-- (allDistinctTyVars tvs tys) returns True if tys are +-- a) all tyvars +-- b) all distinct +-- c) disjoint from tvs +allDistinctTyVars _ [] = True +allDistinctTyVars tkvs (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` tkvs -> False + | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys + +----------------------- +type TypeSize = IntWithInf + +sizeType :: Type -> TypeSize +-- Size of a type: the number of variables and constructors +sizeType ty = toTypeSize (pSizeType ty) + +sizeTypes :: [Type] -> TypeSize +sizeTypes tys = toTypeSize (foldr (addPSize . pSizeType) pSizeZero tys) + +toTypeSize :: PatersonSize -> TypeSize +toTypeSize (PS_TyFam {}) = infinity +toTypeSize (PS_Vanilla { ps_size = size }) = mkIntWithInf size diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -2,8 +2,6 @@ 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 @@ -14,6 +12,4 @@ isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool isConcreteTyVar :: TcTyVar -> Bool - -tcEqType :: HasDebugCallStack => Type -> Type -> Bool diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -48,13 +48,15 @@ import GHC.Data.List.SetOps import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn) +import Control.DeepSeq import Data.Data ( Data ) import Data.Either ( partitionEithers ) +import Data.Functor.Classes ( liftCompare ) import Data.List ( find ) import Data.Maybe +import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- -- The AvailInfo type @@ -166,8 +168,7 @@ stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` - (cmpList stableGreNameCmp ns ms) +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms stableAvailCmp (AvailTC {}) (Avail {}) = GT stableGreNameCmp :: GreName -> GreName -> Ordering @@ -272,10 +273,17 @@ ppr (NormalGreName n) = ppr n ppr (FieldGreName fl) = ppr fl +instance NFData GreName where + rnf (NormalGreName n) = rnf n + rnf (FieldGreName f) = rnf f + instance HasOccName GreName where occName (NormalGreName n) = occName n occName (FieldGreName fl) = occName fl +instance Ord GreName where + compare = stableGreNameCmp + -- | A 'Name' for internal use, but not for output to the user. For fields, the -- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader. greNameMangledName :: GreName -> Name @@ -315,10 +323,10 @@ plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (True,True) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2)) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2))) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionListsOrd` (s2:ss2)) plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name @@ -363,7 +371,7 @@ pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) - = ppr n <> braces (fsep (punctuate comma (map ppr ns))) + = ppr n <> braces (pprWithCommas ppr ns) instance Binary AvailInfo where put_ bh (Avail aa) = do @@ -382,6 +390,10 @@ ac <- get bh return (AvailTC ab ac) +instance NFData AvailInfo where + rnf (Avail n) = rnf n + rnf (AvailTC a b) = rnf a `seq` rnf b + instance Binary GreName where put_ bh (NormalGreName aa) = do putByte bh 0 @@ -396,3 +408,4 @@ return (NormalGreName aa) _ -> do ab <- get bh return (FieldGreName ab) + diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -14,13 +14,12 @@ \end{itemize} -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Types.Basic ( LeftOrRight(..), pickLR, @@ -48,7 +47,8 @@ CbvMark(..), isMarkedCbv, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, + starPrec, appPrec, maxPrec, maybeParen, TupleSort(..), tupleSortBoxity, boxityTupleSort, @@ -97,17 +97,17 @@ setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, pprInline, pprInlineDebug, + UnfoldingSource(..), isStableSource, isStableUserSource, + isStableSystemSource, isCompulsorySource, + SuccessFlag(..), succeeded, failed, successIf, IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, - SpliceExplicitFlag(..), - TypeOrKind(..), isTypeLevel, isKindLevel, Levity(..), mightBeLifted, mightBeUnlifted, - - ExprOrPat(..), + TypeOrConstraint(..), NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, @@ -126,14 +126,14 @@ import qualified GHC.LanguageExtensions as LangExt import Data.Data 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 ) @@ -199,12 +199,6 @@ ************************************************************************ -} --- | A *one-index* constructor tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - -- | A *zero-indexed* constructor tag type ConTagZ = Int @@ -289,14 +283,14 @@ f g x = Just (case g x of { ... }) Here 'f' is lazy in 'g', but it guarantees to call it no - more than once. So g will get a C1(U) usage demand. + more than once. So g will get a C(1,U) usage demand. * Occurrence analysis propagates this usage information (in the demand signature of a function) to its calls. Example, given 'f' above f (\x.e) blah - Since f's demand signature says it has a C1(U) usage demand on its + Since f's demand signature says it has a C(1,U) usage demand on its first argument, the occurrence analyser sets the \x to be one-shot. This is done via the occ_one_shots field of OccEnv. @@ -364,7 +358,7 @@ bestOneShot OneShotLam _ = OneShotLam pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo NoOneShotInfo = text "NoOS" pprOneShotInfo OneShotLam = text "OneShot" instance Outputable OneShotInfo where @@ -405,16 +399,6 @@ * * ********************************************************************* -} --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - instance Outputable PromotionFlag where ppr NotPromoted = text "NotPromoted" ppr IsPromoted = text "IsPromoted" @@ -502,15 +486,6 @@ ************************************************************************ -} -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - instance Outputable Boxity where ppr Boxed = text "Boxed" ppr Unboxed = text "Unboxed" @@ -621,7 +596,7 @@ -} -- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in "GHC.Core.InstEnv") for a +-- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a -- explanation of the `isSafeOverlap` field. -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : @@ -771,16 +746,17 @@ 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 @@ -1367,7 +1343,7 @@ isAlwaysActive _ = False competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] +-- See Note [Competing activations] competesWith AlwaysActive _ = True competesWith NeverActive _ = False @@ -1459,7 +1435,7 @@ It's not possible to get that combination by *writing* something, so if an Id has defaultInlinePragma it means the user didn't specify anything. -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. +If inl_inline = Inline or Inlineable, then the Id should have a stable unfolding. If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair @@ -1773,9 +1749,11 @@ inlinePragmaName (Opaque _) = text "OPAQUE" inlinePragmaName NoUserInlinePrag = empty +-- | Pretty-print without displaying the user-specified 'InlineSpec'. pprInline :: InlinePragma -> SDoc pprInline = pprInline' True +-- | Pretty-print including the user-specified 'InlineSpec'. pprInlineDebug :: InlinePragma -> SDoc pprInlineDebug = pprInline' False @@ -1802,7 +1780,63 @@ | otherwise = ppr info +{- ********************************************************************* +* * + UnfoldingSource +* * +********************************************************************* -} +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + VanillaSrc -- The current rhs of the function + -- Replace uf_tmpl each time around + + -- See Note [Stable unfoldings] in GHC.Core + | StableUserSrc -- From a user-specified INLINE or INLINABLE pragma + | StableSystemSrc -- From a wrapper, or system-generated unfolding + + | CompulsorySrc -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + +isStableUserSource :: UnfoldingSource -> Bool +isStableUserSource StableUserSrc = True +isStableUserSource _ = False + +isStableSystemSource :: UnfoldingSource -> Bool +isStableSystemSource StableSystemSrc = True +isStableSystemSource _ = False + +isCompulsorySource :: UnfoldingSource -> Bool +isCompulsorySource CompulsorySrc = True +isCompulsorySource _ = False + +isStableSource :: UnfoldingSource -> Bool +isStableSource CompulsorySrc = True +isStableSource StableSystemSrc = True +isStableSource StableUserSrc = True +isStableSource VanillaSrc = False + +instance Binary UnfoldingSource where + put_ bh CompulsorySrc = putByte bh 0 + put_ bh StableUserSrc = putByte bh 1 + put_ bh StableSystemSrc = putByte bh 2 + put_ bh VanillaSrc = putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> return CompulsorySrc + 1 -> return StableUserSrc + 2 -> return StableSystemSrc + _ -> return VanillaSrc + +instance Outputable UnfoldingSource where + ppr CompulsorySrc = text "Compulsory" + ppr StableUserSrc = text "StableUser" + ppr StableSystemSrc = text "StableSystem" + ppr VanillaSrc = text "" + {- ************************************************************************ * * @@ -1877,11 +1911,6 @@ mkIntWithInf :: Int -> IntWithInf mkIntWithInf = Int -data SpliceExplicitFlag - = ExplicitSplice | -- ^ <=> $(f x y) - ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression - deriving Data - {- ********************************************************************* * * Types vs Kinds @@ -1906,10 +1935,17 @@ {- ********************************************************************* * * - 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 @@ -1927,24 +1963,10 @@ mightBeUnlifted (Just Lifted) = False mightBeUnlifted _ = True -{- ********************************************************************* -* * - Expressions vs Patterns -* * -********************************************************************* -} - --- | Are we dealing with an expression or a pattern? --- --- Used only for the textual output of certain error messages; --- see the 'FRRDataConArg' constructor of 'FixedRuntimeRepContext'. -data ExprOrPat - = Expression - | Pattern - deriving Eq +data TypeOrConstraint + = TypeLike | ConstraintLike + deriving( Eq, Ord, Data ) -instance Outputable ExprOrPat where - ppr Expression = text "expression" - ppr Pattern = text "pattern" {- ********************************************************************* * * diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs --- a/compiler/GHC/Types/CostCentre.hs +++ b/compiler/GHC/Types/CostCentre.hs @@ -1,9 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} module GHC.Types.CostCentre ( - CostCentre(..), CcName, CCFlavour(..), - -- All abstract except to friend: ParseIface.y + -- All abstract except to friend: ParseIface.y + CostCentre(..), CcName, CCFlavour, + mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour, + mkLateCCFlavour, mkCallerCCFlavour, + pprCostCentre, CostCentreStack, + pprCostCentreStack, CollectedCCs, emptyCollectedCCs, collectCC, currentCCS, dontCareCCS, isCurrentCCS, @@ -31,7 +35,6 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State -import GHC.Utils.Panic.Plain import Data.Data @@ -64,24 +67,39 @@ type CcName = FastString +data IndexedCCFlavour + = ExprCC -- ^ Explicitly annotated expression + | DeclCC -- ^ Explicitly annotated declaration + | HpcCC -- ^ Generated by HPC for coverage + | LateCC -- ^ Annotated by the one of the prof-last* passes. + | CallerCC -- ^ Annotated by the one of the prof-last* passes. + deriving (Eq,Ord,Data,Enum) -- | The flavour of a cost centre. -- -- Index fields represent 0-based indices giving source-code ordering of -- centres with the same module, name, and flavour. -data CCFlavour = CafCC -- ^ Auto-generated top-level thunk - | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression - | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration - | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage - | LateCC !CostCentreIndex -- ^ Annotated by the one of the prof-last* passes. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk, they all go into the same bucket + | IndexedCC !IndexedCCFlavour !CostCentreIndex -- ^ Explicitly annotated expression deriving (Eq, Ord, Data) +-- Construct a CC flavour +mkCafFlavour :: CCFlavour +mkCafFlavour = CafCC +mkExprCCFlavour :: CostCentreIndex -> CCFlavour +mkExprCCFlavour idx = IndexedCC ExprCC idx +mkDeclCCFlavour :: CostCentreIndex -> CCFlavour +mkDeclCCFlavour idx = IndexedCC DeclCC idx +mkHpcCCFlavour :: CostCentreIndex -> CCFlavour +mkHpcCCFlavour idx = IndexedCC HpcCC idx +mkLateCCFlavour :: CostCentreIndex -> CCFlavour +mkLateCCFlavour idx = IndexedCC LateCC idx +mkCallerCCFlavour :: CostCentreIndex -> CCFlavour +mkCallerCCFlavour idx = IndexedCC CallerCC idx + -- | Extract the index from a flavour flavourIndex :: CCFlavour -> Int flavourIndex CafCC = 0 -flavourIndex (ExprCC x) = unCostCentreIndex x -flavourIndex (DeclCC x) = unCostCentreIndex x -flavourIndex (HpcCC x) = unCostCentreIndex x -flavourIndex (LateCC x) = unCostCentreIndex x +flavourIndex (IndexedCC _flav x) = unCostCentreIndex x instance Eq CostCentre where c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } @@ -159,9 +177,9 @@ -- Unique. -- See bug #249, tests prof001, prof002, also #2411 str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) + | otherwise = concatFS [occNameFS (getOccName id), + fsLit "_", + mkFastString (show (getUnique name))] mkAllCafsCC :: Module -> SrcSpan -> CostCentre mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } @@ -236,10 +254,14 @@ -- expression. instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + ppr = pprCostCentreStack +pprCostCentreStack :: IsLine doc => CostCentreStack -> doc +pprCostCentreStack CurrentCCS = text "CCCS" +pprCostCentreStack DontCareCCS = text "CCS_DONT_CARE" +pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs" +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-} +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ----------------------------------------------------------------------------- -- Printing Cost Centres @@ -256,11 +278,16 @@ -- by costCentreName. instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) + ppr = pprCostCentre +pprCostCentre :: IsLine doc => CostCentre -> doc +pprCostCentre cc = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) + then ppCostCentreLbl cc + else ftext (costCentreUserNameFS cc) +{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} +{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc pprCostCentreCore (AllCafsCC {cc_mod = m}) @@ -284,26 +311,35 @@ pprIdxCore idx = whenPprDebug $ ppr idx -- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl :: IsLine doc => CostCentre -> doc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModule m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> ppFlavourLblComponent f <> text "_cc" +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-} +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc ppFlavourLblComponent CafCC = text "CAF" -ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i -ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i -ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i -ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i +ppFlavourLblComponent (IndexedCC flav i) = + case flav of + ExprCC -> text "EXPR" <> ppIdxLblComponent i + DeclCC -> text "DECL" <> ppIdxLblComponent i + HpcCC -> text "HPC" <> ppIdxLblComponent i + LateCC -> text "LATECC" <> ppIdxLblComponent i + CallerCC -> text "CALLERCC" <> ppIdxLblComponent i +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-} +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc ppIdxLblComponent n = case unCostCentreIndex n of 0 -> empty - n -> ppr n + n -> int n +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-} +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration @@ -322,28 +358,18 @@ instance Binary CCFlavour where put_ bh CafCC = - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - put_ bh (LateCC i) = do - putByte bh 4 - put_ bh i + putByte bh 0 + put_ bh (IndexedCC flav i) = do + putByte bh 1 + let !flav_index = fromEnum flav + put_ bh flav_index + put_ bh i get bh = do h <- getByte bh case h of 0 -> return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - 3 -> HpcCC <$> get bh - 4 -> LateCC <$> get bh - _ -> panic "Invalid CCFlavour" + _ -> do + IndexedCC <$> (toEnum <$> get bh) <*> get bh instance Binary CostCentre where put_ bh (NormalCC aa ab ac _ad) = do diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -10,7 +10,8 @@ CprType (..), topCprType, botCprType, flatConCprType, lubCprType, applyCprTy, abstractCprTy, trimCprTy, UnpackConFieldsResult (..), unpackConFieldsCpr, - CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig + CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, + seqCprSig, prependArgsCprSig ) where import GHC.Prelude @@ -186,6 +187,13 @@ seqCprSig :: CprSig -> () seqCprSig (CprSig ty) = seqCprTy ty + +prependArgsCprSig :: Arity -> CprSig -> CprSig +-- ^ Add extra value args to CprSig +prependArgsCprSig n_extra cpr_sig@(CprSig (CprType arity cpr)) + | n_extra == 0 = cpr_sig + | otherwise = assertPpr (n_extra > 0) (ppr n_extra) $ + CprSig (CprType (arity + n_extra) cpr) -- | BNF: -- diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -2,8 +2,6 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -39,31 +37,36 @@ -- ** Other @Demand@ operations oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, - mkWorkerDemand, + mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information argOneShots, argsOneShots, saturatedByOneShots, -- ** Manipulating Boxity of a Demand unboxDeeplyDmd, + -- * Demand environments + DmdEnv, emptyDmdEnv, + keepAliveDmdEnv, reuseEnv, + -- * Divergence Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, - -- * Demand environments - DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, - reuseEnv, - -- * Demand types DmdType(..), dmdTypeDepth, -- ** Algebra nopDmdType, botDmdType, - lubDmdType, plusDmdType, multDmdType, discardArgDmds, + lubDmdType, plusDmdType, multDmdType, + -- *** PlusDmdArg + PlusDmdArg, mkPlusDmdArg, toPlusDmdArg, -- ** Other operations peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, + keepAliveDmdType, -- * Demand signatures - DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, + DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig, splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig, - nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig, + nopSig, botSig, isNopSig, isBottomingSig, isDeadEndSig, isDeadEndAppSig, + trimBoxityDmdSig, transferArgBoxityDmdSig, + -- ** Handling arity adjustments prependArgsDmdSig, etaConvertDmdSig, @@ -82,8 +85,9 @@ import GHC.Prelude -import GHC.Types.Var +import GHC.Types.Var ( Var, Id ) import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe ( orElse ) @@ -102,9 +106,6 @@ import Data.Coerce (coerce) import Data.Function -import GHC.Utils.Trace -_ = pprTrace -- Tired of commenting out the import all the time - {- ************************************************************************ * * @@ -267,7 +268,7 @@ frequently than small records (e.g., Int). Result: Big records tend to be passed around boxed (unmodified) much more frequently than small records. -Consequnce: The larger the record, the more likely conditions (1) and (2) from +Consequence: The larger the record, the more likely conditions (1) and (2) from Note [Function body boxity and call sites] are met, in which case unboxing returned parameters leads to reboxing. @@ -376,9 +377,6 @@ -- See Note [Boxity analysis] for the lattice. lubBoxity = boxedWins -plusBoxity :: Boxity -> Boxity -> Boxity -plusBoxity = boxedWins - {- ************************************************************************ * * @@ -473,6 +471,7 @@ - Handy special cases: o 'plusCard C_10' bumps up the strictness of its argument, just like 'lubCard C_00' lazifies it, without touching upper bounds. + See also 'strictifyCard' o Similarly, 'plusCard C_0N' discards usage information (incl. absence) but leaves strictness alone. @@ -561,15 +560,22 @@ -- | Intersect with [0,1]. oneifyCard :: Card -> Card -oneifyCard C_0N = C_01 -oneifyCard C_1N = C_11 -oneifyCard c = c +oneifyCard = glbCard C_01 +-- | Intersect with [1,n]. The same as @'plusCard' 'C_10'@. +strictifyCard :: Card -> Card +strictifyCard = glbCard C_1N + -- | Denotes '∪' on 'Card'. lubCard :: Card -> Card -> Card -- See Note [Bit vector representation for Card] lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding! +-- | Denotes '∩' on 'Card'. +glbCard :: Card -> Card -> Card +-- See Note [Bit vector representation for Card] +glbCard (Card a) (Card b) = Card (a .&. b) + -- | Denotes '+' on lower and upper bounds of 'Card'. plusCard :: Card -> Card -> Card -- See Note [Algebraic specification for plusCard and multCard] @@ -598,11 +604,11 @@ ************************************************************************ -} --- | A demand describes a /scaled evaluation context/, e.g. how many times --- and how deep the denoted thing is evaluated. +-- | A demand describes -- --- The "how many" component is represented by a 'Card'inality. --- The "how deep" component is represented by a 'SubDemand'. +-- * How many times a variable is evaluated, via a 'Card'inality, and +-- * How deep its value was evaluated in turn, via a 'SubDemand'. +-- -- Examples (using Note [Demand notation]): -- -- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument @@ -610,10 +616,10 @@ -- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument -- pair strictly and the first component strictly, but no nested info -- beyond that (@L@). Its second argument is not used at all. --- * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the +-- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the -- argument function with one argument, exactly once (@1@). No info -- on how the result of that call is evaluated (@L@). --- * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates +-- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates -- the argument function at most once ((M)aybe) and calls it once when -- it is evaluated. -- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@ @@ -643,11 +649,11 @@ -- | Only meant to be used in the pattern synonym below! viewDmdPair :: Demand -> (Card, SubDemand) viewDmdPair BotDmd = (C_10, botSubDmd) -viewDmdPair AbsDmd = (C_00, seqSubDmd) +viewDmdPair AbsDmd = (C_00, botSubDmd) viewDmdPair (D n sd) = (n, sd) --- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it --- was evaluated, it was at least as deep as @sd@\". +-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and any trace in +-- which it is evaluated will evaluate at least as deep as @sd@\". -- -- Matching on this pattern synonym is a complete match. -- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@. @@ -663,27 +669,18 @@ pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand pattern n :* sd <- (viewDmdPair -> (n, sd)) where C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd) - C_00 :* sd = AbsDmd & assertPpr (sd == seqSubDmd) (text "A /=" <+> ppr sd) + C_00 :* sd = AbsDmd & assertPpr (sd == botSubDmd) (text "A /=" <+> ppr sd) n :* sd = D n sd & assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) {-# COMPLETE (:*) #-} --- | A sub-demand describes an /evaluation context/, e.g. how deep the --- denoted thing is evaluated. See 'Demand' for examples. --- --- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call. --- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@: --- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an --- additional argument. +-- | A sub-demand describes an /evaluation context/ (in the sense of an +-- operational semantics), e.g. how deep the denoted thing is going to be +-- evaluated. See 'Demand' for examples. -- --- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/: --- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that --- the denoted sub-expression is used once in the entire evaluation context --- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the --- field of the denoted expression is used at most once, although the --- entire expression might be used many times. +-- See Note [SubDemand denotes at least one evaluation] for a more detailed +-- description of what a sub-demand means. -- --- See Note [Call demands are relative] --- and Note [Demand notation]. +-- See Note [Demand notation] for the extensively used short-hand notation. -- See also Note [Why Boxity in SubDemand and not in Demand?]. data SubDemand = Poly !Boxity !CardNonOnce @@ -696,18 +693,23 @@ -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly b n, ...] -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites. -- - -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@, - -- @B === P(B,B,...)@ and @B === CB(B)@, - -- @!A === !P(A,A,...)@ and @!A === !CA(A)@, + -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === C(L)@, + -- @B === P(B,B,...)@ and @B === C(B)@, + -- @!A === !P(A,A,...)@ and @!A === C(A)@, -- and so on. -- -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'. + -- + -- Why doesn't this constructor simply carry a 'Demand' instead of its fields? + -- See Note [Call SubDemand vs. evaluation Demand]. | Call !CardNonAbs !SubDemand -- ^ @Call n sd@ describes the evaluation context of @n@ function - -- applications, where every individual result is evaluated according to @sd@. - -- @sd@ is /relative/ to a single call, see Note [Call demands are relative]. + -- applications (with one argument), where the result of each call is + -- evaluated according to @sd@. + -- @sd@ describes program traces in which the denoted thing was called at all, + -- see Note [SubDemand denotes at least one evaluation]. -- That Note also explains why it doesn't make sense for @n@ to be absent, -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be -- expressed with 'Poly'. @@ -780,19 +782,21 @@ -- for Arity. Otherwise, #18304 bites us. -- | A smart constructor for 'Call', applying rewrite rules along the semantic --- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's +-- equality @Call C_0N (Poly C_0N) === Poly C_0N@, simplifying to 'Poly' 'SubDemand's -- when possible. mkCall :: CardNonAbs -> SubDemand -> SubDemand -mkCall C_1N sd@(Poly Boxed C_1N) = sd +--mkCall C_1N sd@(Poly Boxed C_1N) = sd -- NO! #21085 strikes. See Note [mkCall and plusSubDmd] mkCall C_0N sd@(Poly Boxed C_0N) = sd -mkCall n cd = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $ - Call n cd +mkCall n sd = assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) $ + Call n sd -- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as -- necessary. viewCall :: SubDemand -> Maybe (Card, SubDemand) viewCall (Call n sd) = Just (n :: Card, sd) -viewCall (Poly _ n) = Just (n :: Card, Poly Boxed n) +viewCall (Poly _ n) + | isAbs n = Just (n :: Card, botSubDmd) + | otherwise = Just (n :: Card, Poly Boxed n) viewCall _ = Nothing topDmd, absDmd, botDmd, seqDmd :: Demand @@ -808,42 +812,33 @@ unboxDeeplySubDmd call@Call{} = call -- | Sets 'Boxity' to 'Unboxed' for the 'Demand', recursing into 'Prod's. +-- Don't recurse into lazy arguments; see GHC.Core.Opt.DmdAnal +-- Note [No lazy, Unboxed demands in demand signature] unboxDeeplyDmd :: Demand -> Demand unboxDeeplyDmd AbsDmd = AbsDmd unboxDeeplyDmd BotDmd = BotDmd -unboxDeeplyDmd (D n sd) = D n (unboxDeeplySubDmd sd) +unboxDeeplyDmd dmd@(D n sd) | isStrict n = D n (unboxDeeplySubDmd sd) + | otherwise = dmd --- | Denotes '∪' on 'SubDemand'. -lubSubDmd :: SubDemand -> SubDemand -> SubDemand --- Handle botSubDmd (just an optimisation, the general case would do the same) -lubSubDmd (Poly Unboxed C_10) d2 = d2 -lubSubDmd d1 (Poly Unboxed C_10) = d1 --- Handle Prod -lubSubDmd (Prod b1 ds1) (Poly b2 n2) - | let !d = polyFieldDmd b2 n2 - = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1) -lubSubDmd (Prod b1 ds1) (Prod b2 ds2) - | equalLength ds1 ds2 - = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) --- Handle Call -lubSubDmd (Call n1 sd1) sd2@(Poly _ n2) - -- See Note [Call demands are relative] - | isAbs n2 = mkCall (lubCard n2 n1) sd1 - | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 sd2) -lubSubDmd (Call n1 d1) (Call n2 d2) - | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2) --- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again). -lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2) -lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 --- Otherwise (Call `lub` Prod) return Top -lubSubDmd _ _ = topSubDmd --- | Denotes '∪' on 'Demand'. -lubDmd :: Demand -> Demand -> Demand -lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2 +multDmd :: Card -> Demand -> Demand +multDmd C_11 dmd = dmd -- An optimisation +-- The following four lines make sure that we rewrite to AbsDmd and BotDmd +-- whenever the leading cardinality is absent (C_00 or C_10). +-- Otherwise it may happen that the SubDemand is not 'botSubDmd', triggering +-- the assertion in `:*`. +-- Example: `multDmd B 1L = BA`, so with an inner `seqSubDmd`. Our lattice +-- allows us to always rewrite this to proper BotDmd and we maintain the +-- invariant that this is indeed the case. +multDmd C_00 _ = AbsDmd +multDmd _ AbsDmd = AbsDmd +multDmd C_10 (D n _) = if isStrict n then BotDmd else AbsDmd +multDmd n BotDmd = if isStrict n then BotDmd else AbsDmd +-- See Note [SubDemand denotes at least one evaluation] for the strictifyCard +multDmd n (D m sd) = multCard n m :* multSubDmd (strictifyCard n) sd multSubDmd :: Card -> SubDemand -> SubDemand -multSubDmd C_11 sd = sd +multSubDmd C_11 sd = sd -- An optimisation, for when sd is a deep Prod -- The following three equations don't have an impact on Demands, only on -- Boxity. They are needed so that we don't trigger the assertions in `:*` -- when called from `multDmd`. @@ -851,46 +846,77 @@ multSubDmd C_10 (Poly _ n) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B` multSubDmd C_10 (Call n _) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality multSubDmd n (Poly b m) = Poly b (multCard n m) -multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative] +multSubDmd n (Call n' sd) = mkCall (multCard n n') sd multSubDmd n (Prod b ds) = mkProd b (strictMap (multDmd n) ds) -multDmd :: Card -> Demand -> Demand --- The first two lines compute the same result as the last line, but won't --- trigger the assertion in `:*` for input like `multDmd B 1L`, which would call --- `B :* A`. We want to return `B` in these cases. -multDmd C_10 (n :* _) = if isStrict n then BotDmd else AbsDmd -multDmd n (C_10 :* _) = if isStrict n then BotDmd else AbsDmd -multDmd n (m :* sd) = multCard n m :* multSubDmd n sd +lazifyIfStrict :: Card -> SubDemand -> SubDemand +lazifyIfStrict n sd = multSubDmd (glbCard C_01 n) sd --- | Denotes '+' on 'SubDemand'. +-- | Denotes '∪' on 'Demand'. +lubDmd :: Demand -> Demand -> Demand +lubDmd BotDmd dmd2 = dmd2 +lubDmd dmd1 BotDmd = dmd1 +lubDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "lubDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + lubCard n1 n2 :* lubSubDmd sd1 sd2 + +lubSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +lubSubDmd (Poly Unboxed C_10) sd = sd +lubSubDmd sd (Poly Unboxed C_10) = sd +lubSubDmd sd@(Poly Boxed C_0N) _ = sd +lubSubDmd _ sd@(Poly Boxed C_0N) = sd +-- Handle Prod +lubSubDmd (Prod b1 ds1) (Poly b2 n2) + | let !d = polyFieldDmd b2 n2 + = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1) +lubSubDmd (Prod b1 ds1) (Prod b2 ds2) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) +-- Handle Call +lubSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (lubCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2) +-- Other Poly case by commutativity +lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 +-- Otherwise (Call `lub` Prod) return Top +lubSubDmd _ _ = topSubDmd + +-- | Denotes '+' on 'Demand'. +plusDmd :: Demand -> Demand -> Demand +plusDmd AbsDmd dmd2 = dmd2 +plusDmd dmd1 AbsDmd = dmd1 +plusDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "plusDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + -- Why lazify? See Note [SubDemand denotes at least one evaluation] + -- and also Note [Unrealised opportunity in plusDmd] which applies when both + -- n1 and n2 are lazy already + plusCard n1 n2 :* plusSubDmd (lazifyIfStrict n1 sd1) (lazifyIfStrict n2 sd2) + plusSubDmd :: SubDemand -> SubDemand -> SubDemand --- Handle seqSubDmd (just an optimisation, the general case would do the same) -plusSubDmd (Poly Unboxed C_00) d2 = d2 -plusSubDmd d1 (Poly Unboxed C_00) = d1 +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +plusSubDmd (Poly Unboxed C_00) sd = sd +plusSubDmd sd (Poly Unboxed C_00) = sd +plusSubDmd sd@(Poly Boxed C_1N) _ = sd +plusSubDmd _ sd@(Poly Boxed C_1N) = sd -- Handle Prod plusSubDmd (Prod b1 ds1) (Poly b2 n2) | let !d = polyFieldDmd b2 n2 - = mkProd (plusBoxity b1 b2) (strictMap (plusDmd d) ds1) + = mkProd (lubBoxity b1 b2) (strictMap (plusDmd d) ds1) plusSubDmd (Prod b1 ds1) (Prod b2 ds2) | equalLength ds1 ds2 - = mkProd (plusBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) + = mkProd (lubBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) -- Handle Call -plusSubDmd (Call n1 sd1) sd2@(Poly _ n2) - -- See Note [Call demands are relative] - | isAbs n2 = mkCall (plusCard n2 n1) sd1 - | otherwise = mkCall (plusCard n2 n1) (lubSubDmd sd1 sd2) -plusSubDmd (Call n1 sd1) (Call n2 sd2) - | otherwise = mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) --- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again). -plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (plusBoxity b1 b2) (plusCard n1 n2) +plusSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (plusCard n1 n2) +-- Other Poly case by commutativity plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 --- Otherwise (Call `lub` Prod) return Top +-- Otherwise (Call `plus` Prod) return Top plusSubDmd _ _ = topSubDmd --- | Denotes '+' on 'Demand'. -plusDmd :: Demand -> Demand -> Demand -plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2 - -- | Used to suppress pretty-printing of an uninformative demand isTopDmd :: Demand -> Bool isTopDmd dmd = dmd == topDmd @@ -927,27 +953,27 @@ -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd is_plus_idem_sub_dmd (Poly _ n) = assert (isCardNonOnce n) True is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds - is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] + is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n evalDmd :: Demand evalDmd = C_1N :* topSubDmd --- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@. +-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C(1,L)@. -- Called exactly once. strictOnceApply1Dmd :: Demand strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd --- | First argument of 'GHC.Exts.atomically#': @SCS(L)@. +-- | First argument of 'GHC.Exts.atomically#': @SC(S,L)@. -- Called at least once, possibly many times. strictManyApply1Dmd :: Demand strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd --- | First argument of catch#: @MCM(L)@. +-- | First argument of catch#: @MC(M,L)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd --- | Second argument of catch#: @MCM(C1(L))@. +-- | Second argument of catch#: @MC(M,C(1,L))@. -- Calls its arg lazily, but then applies it exactly once to an additional argument. lazyApply2Dmd :: Demand lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd) @@ -960,9 +986,7 @@ -- | Make a 'Demand' evaluated at-least-once (e.g. strict). strictifyDmd :: Demand -> Demand -strictifyDmd AbsDmd = seqDmd -strictifyDmd BotDmd = BotDmd -strictifyDmd (n :* sd) = plusCard C_10 n :* sd +strictifyDmd = plusDmd seqDmd -- | If the argument is a used non-newtype dictionary, give it strict demand. -- Also split the product type & demand and recur in order to similarly @@ -987,23 +1011,15 @@ = Nothing strictifyDictDmd _ dmd = dmd --- | Make a 'Demand' lazy, setting all lower bounds (outside 'Call's) to 0. +-- | Make a 'Demand' lazy. lazifyDmd :: Demand -> Demand -lazifyDmd AbsDmd = AbsDmd -lazifyDmd BotDmd = AbsDmd -lazifyDmd (n :* sd) = multCard C_01 n :* lazifySubDmd sd - --- | Make a 'SubDemand' lazy, setting all lower bounds (outside 'Call's) to 0. -lazifySubDmd :: SubDemand -> SubDemand -lazifySubDmd (Poly b n) = Poly b (multCard C_01 n) -lazifySubDmd (Prod b sd) = mkProd b (strictMap lazifyDmd sd) -lazifySubDmd (Call n sd) = mkCall (lubCard C_01 n) sd +lazifyDmd = multDmd C_01 --- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@. +-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd --- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. +-- | @mkCalledOnceDmds n d@ returns @C(1,C1...C(1,d))@ where there are @n@ @C1@'s. mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity @@ -1024,15 +1040,21 @@ go _ _ _ = (topCard, topSubDmd) {-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context +-- | Extract the 'SubDemand' of a 'Demand'. +-- PRECONDITION: The SubDemand must be used in a context where the expression +-- denoted by the Demand is under evaluation. +subDemandIfEvaluated :: Demand -> SubDemand +subDemandIfEvaluated (_ :* sd) = sd + -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap mkWorkerDemand :: Int -> Demand mkWorkerDemand n = C_01 :* go n where go 0 = topSubDmd - go n = Call C_01 $ go (n-1) + go n = mkCall C_01 $ go (n-1) argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] -argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args +argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args | unsaturated_call = [] | otherwise = go arg_ds where @@ -1051,7 +1073,7 @@ argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd = [] -- according to which we should return -- @repeat OneShotLam@ here... -argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] +argOneShots (_ :* sd) = go sd where go (Call n sd) | isUsedOnce n = OneShotLam : go sd @@ -1059,9 +1081,9 @@ go _ = [] -- | --- @saturatedByOneShots n CM(CM(...)) = True@ +-- @saturatedByOneShots n C(M,C(M,...)) = True@ -- <=> --- There are at least n nested CM(..) calls. +-- There are at least n nested C(M,..) calls. -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd = True @@ -1088,54 +1110,223 @@ In #7319 we get T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] -Note [Call demands are relative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand -@LCL(C1(P(L)))@, meaning +Note [SubDemand denotes at least one evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a demand `n :* sd` on a binding `let x = e in `. +(Similarly, a call sub-demand `Cn(sd)` on a lambda `\_. e`). +While `n` describes how *often* `x` had been evaluated in , +the sub-demand `sd` describes how *deep* `e` has been evaluated, under the +following - "f is called multiple times or not at all (CL), but each time it - is called, it's called with *exactly one* (C1) more argument. - Whenever it is called with two arguments, we have no info on how often - the field of the product result is used (L)." + PREMISE: *for all program traces where `x` had been evaluated at all* -So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call. -And that extends to the information we have how its results are used in each -call site. Consider (#18903) +That is, `sd` disregards all program traces where `x` had not been evaluated, +because it can't describe the depth of an evaluation that never happened. +NB: The Premise only makes a difference for lower bounds/strictness. +Upper bounds/usage are unaffected by adding or leaving out evaluations that +never happen. - h :: Int -> Int - h m = - let g :: Int -> (Int,Int) - g 1 = (m, 0) - g n = (2 * n, 2 `div` n) - {-# NOINLINE g #-} - in case m of - 1 -> 0 - 2 -> snd (g m) - _ -> uncurry (+) (g m) +The Premise comes into play when we have lazy Demands. For example, if `x` was +demanded with `LP(SL,A)`, so perhaps the full expression was + let x = (e1, e2) in (x `seq` fun y `seq` case x of (a,b) -> a, True) +then `x` will be evaluated lazily, but in any trace in which `x` is evaluated, +the pair in its RHS will ultimately be evaluated deeply with sub-demand +`P(SL,A)`. That means that `e1` is ultimately evaluated strictly, even though +evaluation of the field does not directly follow the eval of `x` due to the +intermittent call `fun y`. -We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call -site of @g@, we are strict in the second component of the returned pair. +How does the additional strictness help? The long version is the list of +examples at the end of this Note (as procured in #21081 and #18903). +The short version is -This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd' -in 'plusSubDmd', but if you do the math it's just the right thing. + * We get to take advantage of call-by-value/let-to-case in more situations, + as for e1 above. See example "More let-to-case" below. + * Note [Eta reduction based on evaluation context] applies in more situations. + See example "More eta reduction" below. + * We get to unbox more results, see example "More CPR" below. -There's one more subtlety: Since the nested demand is relative to exactly one -call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise -is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures -that @g@ above actually gets the @1P(L)@ demand on its second pair component, -rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand. +It seems like we don't give up anything in return. Indeed that is the case: + * If we dropped the Premise, then a lazy `n` in `nP(m..)` would always force + `m` to be lazy, too. That is quite redundant! It seems wasteful not to use + the lower bound of `m` for something more useful. So indeed we give up on + nothing in return for some nice wins. + * Even if `n` is absent (so the Premise does hold for no trace whatsoever), + it's pretty easy to describe how `e` was evaluated. Answer: 'botSubDmd'. + We use it when expanding 'Absent' and 'Bottom' demands in 'viewDmdPair' as + well as when expanding absent 'Poly's to 'Call' sub-demands in 'viewCall'. + +Of course, we now have to maintain the Premise when we unpack and rebuild +Demands. For strict demands, we know that the Premise indeed always holds for +any program trace abstracted over, whereas we have to be careful for lazy +demands. + +In particular, when doing `plusDmd` we have to *lazify* the nested SubDemand +if the outer cardinality is lazy. E.g., + LP(SL) + SP(L) = (L+S)P((M*SL)+L) = SP(L+L) = SP(L) +Multiplying with `M`/`C_01` is the "lazify" part here and is implemented in +`lazifyIfStrict`. Example proving that point: + d2 :: + d2 x y = y `seq` (case x of (a,b) -> a, True) + -- What is the demand on x in (d2 x x)? NOT SP(SL)!! + +We used to apply the same reasoning to Call SubDemands `Cn(sd)` in `plusSubDmd`, +but that led to #21717, because different calls return different heap objects. +See Note [Call SubDemand vs. evaluation Demand]. + +There are a couple more examples that improve in T21081. +Here is a selection of those examples demonstrating the usefulness of The +Premise: + + * "More let-to-case" (from testcase T21081): + ```hs + f :: (Bool, Bool) -> (Bool, Bool) + f pr = (case pr of (a,b) -> a /= b, True) + g :: Int -> (Bool, Bool) + g x = let y = let z = odd x in (z,z) in f y + ``` + Although `f` is lazy in `pr`, we could case-bind `z` because it is always + evaluated when `y` is evaluated. So we give `pr` demand `LP(SL,SL)` + (most likely with better upper bounds/usage) and demand analysis then + infers a strict demand for `z`. + + * "More eta reduction" (from testcase T21081): + ```hs + myfoldl :: (a -> b -> a) -> a -> [b] -> a + myfoldl f z [] = z + myfoldl f !z (x:xs) = myfoldl (\a b -> f a b) (f z x) xs + ``` + Here, we can give `f` a demand of `LC(S,C(1,L))` (instead of the lazier + `LC(L,C(1,L))`) which says "Whenever `f` is evaluated (lazily), it is also + called with two arguments". + And Note [Eta reduction based on evaluation context] means we can rewrite + `\a b -> f a b` to `f` in the call site of `myfoldl`. Nice! + + * "More CPR" (from testcase T18903): + ```hs + h :: Int -> Int + h m = + let g :: Int -> (Int,Int) + g 1 = (m, 0) + g n = (2 * n, 2 `div` n) + {-# NOINLINE g #-} + in case m of + 1 -> 0 + 2 -> snd (g m) + _ -> uncurry (+) (g m) + ``` + We want to give `g` the demand `MC(1,P(MP(L),1P(L)))`, so we see that in each + call site of `g`, we are strict in the second component of the returned + pair. That in turn means that Nested CPR can unbox the result of the + division even though it might throw. + +Note [Unrealised opportunity in plusDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the lazification of SubDemands happening in `plusDmd` as described in +Note [SubDemand denotes at least one evaluation]. + +We *could* do better when both Demands are lazy already. Example + (fun 1, fun 2) +Both args put Demand SC(S,L) on `fun`. The lazy pair arg context lazifies +this to LC(S,L), and it would be reasonable to report this Demand on `fun` for +the entire pair expression; after all, `fun` is called whenever it is evaluated. +But our definition of `plusDmd` will compute + LC(S,L) + LC(S,L) = (L+L)(M*C(S,L) + M*C(S,L)) = L(C(L,L)) = L +Which is clearly less precise. +Doing better here could mean to `lub` when both demands are lazy, e.g., + LC(S,L) + LC(S,L) = (L+L)(C(S,L) ⊔ C(S,L)) = L(C(S,L)) +Indeed that's what we did at one point between 9.4 and 9.6 after !7599, but it +means that we need a function `lubPlusSubDmd` that lubs on lower bounds but +plus'es upper bounds, implying maintenance challenges and complicated +explanations. + +Plus, NoFib says that this special case doesn't bring all that much +(geom. mean +0.0% counted instructions), so we don't bother anymore. + +Note [Call SubDemand vs. evaluation Demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although both evaluation Demands and Call SubDemands carry a (Card,SubDemand) +pair, their interpretation is quite different. Example: + + f x = fst x * snd x + -- f :: , because 1P(1L,A)+1P(A,1L) = SP(1L,1L) + g x = fst (x 1) * snd (x 2) + -- g :: , because 1C(1,P(1L,A))+1C(1,P(A,1L)) = SC(S,P(ML,ML)) + +The point about this example is that both demands have P(A,1L)/P(1L,A) as +sub-expressions, but when these sub-demands occur + + 1. under an evaluation demand, we combine with `plusSubDmd` + 2. whereas under a Call sub-demand, we combine with `lubSubDmd` + +And thus (1) yields a stricter demand on the pair components than (2). + +In #21717 we saw that we really need lub in (2), because otherwise we make an +unsound prediction in `g (\n -> if n == 1 then (1,1) else (bot,2))`; we'd say +that the `bot` expression is always evaluated, when it clearly is not. +Operationally, every call to `g` gives back a potentially distinct, +heap-allocated pair with potentially different contents, and we must `lubSubDmd` +over all such calls to approximate how any of those pairs might be used. + +That is in stark contrast to f's argument `x`: Operationally, every eval of +`x` must yield the same pair and `f` evaluates both components of that pair. +The theorem "every eval of `x` returns the same heap object" is a very strong +MUST-alias property and we capitalise on that by using `plusSubDmd` in (1). + +And indeed we *must* use `plusSubDmd` in (1) for sound upper bounds in an +analysis that assumes call-by-need (as opposed to the weaker call-by-name) for +let bindings. Consider + + h x = fst x * fst x + -- h :: + +And the expression `let a=1; p=(a,a)} in h p`. Here, *although* the RHS of `p` +is only evaluated once under call-by-need, `a` is still evaluated twice. +If we had used `lubSubDmd`, we'd see SP(1L,A) and the 1L unsoundly says "exactly +once". + +If the analysis had assumed call-by-name, it would be sound to say "a is used +once in p": p is used multiple times and hence so would a, as if p was a +function. So using `plusSubDmd` does not only yield better strictness, it is +also "holding up the other end of the bargain" of the call-by-need assumption +for upper bounds. + +(To SG's knowledge, the distinction between call-by-name and call-by-need does +not matter for strictness analysis/lower bounds, thus it would be sound to use +`lubSubDmd` all the time there.) + +Note [mkCall and plusSubDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never rewrite a strict, non-absent Call sub-demand like C(S,S) to a +polymorphic sub-demand like S, otherwise #21085 strikes. Consider the +following inequality (would also for M and 1 instead of L and S, but we forbid +such Polys): + + L+S = S = C(S,S) < C(S,L) = C(L,L)+C(S,S) + +Note that L=C(L,L). If we also had S=C(S,S), we'd be in trouble: Now +`plusSubDmd` would no longer maintain the equality relation on sub-demands, +much less monotonicity. Bad! + +Clearly, `n <= Cn(n)` is unproblematic, as is `n >= Cn(n)` for any `n` +except 1 and S. But `C(S,S) >= S` would mean trouble, because then we'd get +the problematic `C(S,S) = S`. We have just established that `S < C(S,S)`! +As such, the rewrite C(S,S) to S is anti-monotone and we forbid it, first +and foremost in `mkCall` (which is the only place that rewrites Cn(n) to n). + +Crisis and #21085 averted! + Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call f (\pqr. e1) (\xyz. e2) e3 where f has usage signature - + Then argsOneShots returns a [[OneShotInfo]] of [[OneShot,NoOneShotInfo,OneShot], [OneShot]] The occurrence analyser propagates this one-shot infor to the binders \pqr and \xyz; -see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal". +see Note [Sources of one-shot information] in GHC.Core.Opt.OccurAnal. Note [Boxity in Poly] ~~~~~~~~~~~~~~~~~~~~~ @@ -1181,7 +1372,7 @@ But then we regressed in T7837 (grep #19871 for boring specifics), which needed to transfer an ambient unboxed *demand* on a dictionary selector to its argument -dictionary, via a 'Call' sub-demand `C1(sd)`, as +dictionary, via a 'Call' sub-demand `C(1,sd)`, as Note [Demand transformer for a dictionary selector] explains. Annoyingly, the boxity info has to be stored in the *sub-demand* `sd`! There's no demand to store the boxity in. So we bit the bullet and now we store Boxity in @@ -1275,7 +1466,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' +-- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be @@ -1486,7 +1677,7 @@ catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). +(beyond `-fno-pedantic-bottoms`). But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is @@ -1546,131 +1737,112 @@ -} -- Subject to Note [Default demand on free variables and arguments] --- | Captures the result of an evaluation of an expression, by --- --- * Listing how the free variables of that expression have been evaluted --- ('de_fvs') --- * Saying whether or not evaluation would surely diverge ('de_div') --- --- See Note [Demand env Equality]. -data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } - -instance Eq DmdEnv where - DE fv1 div1 == DE fv2 div2 - = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2 - where - canonicalise div fv = filterUFM (/= defaultFvDmd div) fv - -mkEmptyDmdEnv :: Divergence -> DmdEnv -mkEmptyDmdEnv div = DE emptyVarEnv div - --- | Build a potentially terminating 'DmdEnv' from a finite map that says what --- has been evaluated so far -mkTermDmdEnv :: VarEnv Demand -> DmdEnv -mkTermDmdEnv fvs = DE fvs topDiv - -nopDmdEnv :: DmdEnv -nopDmdEnv = mkEmptyDmdEnv topDiv - -botDmdEnv :: DmdEnv -botDmdEnv = mkEmptyDmdEnv botDiv - -exnDmdEnv :: DmdEnv -exnDmdEnv = mkEmptyDmdEnv exnDiv - -lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div - where - -- See Note [Demand env Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - lub_div = lubDivergence d1 d2 - -addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv -addVarDmdEnv env@(DE fvs div) id dmd - = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div - -plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -plusDmdEnv (DE fv1 d1) (DE fv2 d2) - -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric. - | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd - = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient - | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd - = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient - | otherwise - = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) - (d1 `plusDivergence` d2) +type DmdEnv = VarEnv Demand --- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' -plusDmdEnvs :: [DmdEnv] -> DmdEnv -plusDmdEnvs [] = nopDmdEnv -plusDmdEnvs pdas = foldl1' plusDmdEnv pdas +emptyDmdEnv :: DmdEnv +emptyDmdEnv = emptyVarEnv multDmdEnv :: Card -> DmdEnv -> DmdEnv -multDmdEnv C_11 env = env -multDmdEnv C_00 _ = nopDmdEnv -multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div) +multDmdEnv C_11 env = env +multDmdEnv C_00 _ = emptyDmdEnv +multDmdEnv n env = mapVarEnv (multDmd n) env reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N -lookupDmdEnv :: DmdEnv -> Id -> Demand --- See Note [Default demand on free variables and arguments] -lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div +-- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have +-- /some/ usage in the returned demand types -- they are not Absent. +-- See Note [Absence analysis for stable unfoldings and RULES] +-- in "GHC.Core.Opt.DmdAnal". +keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv +keepAliveDmdEnv env vs + = nonDetStrictFoldVarSet add env vs + where + add :: Id -> DmdEnv -> DmdEnv + add v env = extendVarEnv_C add_dmd env v topDmd -delDmdEnv :: DmdEnv -> Id -> DmdEnv -delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div + add_dmd :: Demand -> Demand -> Demand + -- If the existing usage is Absent, make it used + -- Otherwise leave it alone + add_dmd dmd _ | isAbsDmd dmd = topDmd + | otherwise = dmd -- | Characterises how an expression -- --- * Evaluates its free variables ('dt_env') including divergence info +-- * Evaluates its free variables ('dt_env') -- * Evaluates its arguments ('dt_args') +-- * Diverges on every code path or not ('dt_div') -- +-- Equality is defined modulo 'defaultFvDmd's in 'dt_env'. +-- See Note [Demand type Equality]. data DmdType = DmdType - { dt_env :: !DmdEnv -- ^ Demands on free variables. - -- See Note [Demand type Divergence] + { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables , dt_args :: ![Demand] -- ^ Demand on arguments + , dt_div :: !Divergence -- ^ Whether evaluation diverges. + -- See Note [Demand type Divergence] } --- | See Note [Demand env Equality]. +-- | See Note [Demand type Equality]. instance Eq DmdType where - DmdType env1 ds1 == DmdType env2 ds2 - = ds1 == ds2 -- cheap checks first - && env1 == env2 + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = div1 == div2 && ds1 == ds2 -- cheap checks first + && canonicalise div1 fv1 == canonicalise div2 fv2 + where + canonicalise div fv = filterUFM (/= defaultFvDmd div) fv -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 = DmdType lub_fv lub_ds +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_div where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1) = etaExpandDmdType n d1 - (DmdType fv2 ds2) = etaExpandDmdType n d2 + (DmdType fv1 ds1 r1) = etaExpandDmdType n d1 + (DmdType fv2 ds2 r2) = etaExpandDmdType n d2 + + -- See Note [Demand type Equality] + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2) lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_fv = lubDmdEnv fv1 fv2 + lub_div = lubDivergence r1 r2 -discardArgDmds :: DmdType -> DmdEnv -discardArgDmds (DmdType fv _) = fv +type PlusDmdArg = (DmdEnv, Divergence) -plusDmdType :: DmdType -> DmdEnv -> DmdType -plusDmdType (DmdType fv ds) fv' - -- See Note [Asymmetry of plusDmdType] - -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation. - = DmdType (plusDmdEnv fv fv') ds +mkPlusDmdArg :: DmdEnv -> PlusDmdArg +mkPlusDmdArg env = (env, topDiv) +toPlusDmdArg :: DmdType -> PlusDmdArg +toPlusDmdArg (DmdType fv _ r) = (fv, r) + +plusDmdType :: DmdType -> PlusDmdArg -> DmdType +plusDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'plus*'] + -- 'plus' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd + = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient + | otherwise + = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) + ds1 + (r1 `plusDivergence` t2) + botDmdType :: DmdType -botDmdType = DmdType botDmdEnv [] +botDmdType = DmdType emptyDmdEnv [] botDiv -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType -nopDmdType = DmdType nopDmdEnv [] +nopDmdType = DmdType emptyDmdEnv [] topDiv +isNopDmdType :: DmdType -> Bool +isNopDmdType (DmdType env args div) + = div == topDiv && null args && isEmptyVarEnv env + -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType -exnDmdType = DmdType exnDmdEnv [] +exnDmdType = DmdType emptyDmdEnv [] exnDiv dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args @@ -1679,7 +1851,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType -etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env} +etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div} | n == depth = d | n > depth = d{dt_args = inc_ds} | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) @@ -1691,7 +1863,7 @@ -- * Divergence is still valid: -- - A dead end after 2 arguments stays a dead end after 3 arguments -- - The remaining case is Dunno, which is already topDiv - inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env))) + inc_ds = take n (ds ++ repeat (defaultArgDmd div)) -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType. @@ -1703,27 +1875,30 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args}) -splitDmdTy ty@DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty) +splitDmdTy ty@DmdType{dt_div=div} = (defaultArgDmd div, ty) multDmdType :: Card -> DmdType -> DmdType -multDmdType n (DmdType fv args) +multDmdType n (DmdType fv args res_ty) = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $ DmdType (multDmdEnv n fv) (map (multDmd n) args) + (multDivergence n res_ty) peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds, dmd) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) where -- Force these arguments so that old `Env` is not retained. - !fv' = fv `delDmdEnv` id - !dmd = lookupDmdEnv fv id + !fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables and arguments] + !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds) +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _) id = lookupDmdEnv fv id +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultFvDmd res -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is @@ -1739,6 +1914,11 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType +-- | See 'keepAliveDmdEnv'. +keepAliveDmdType :: DmdType -> VarSet -> DmdType +keepAliveDmdType (DmdType fvs ds res) vars = + DmdType (fvs `keepAliveDmdEnv` vars) ds res + {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis] @@ -1764,9 +1944,9 @@ (# s', r) -> f x which uses `x` *boxed*. If we `lub`bed it with `(DmdType emptyDmdEnv [] exnDiv)` -we'd get an *unboxed* demand on `x` (because we let Unboxed win), which led to -ticket #20746. -Nowadays with `lubBoxity = boxedWins` we don't need the complicated definition. +we'd get an *unboxed* demand on `x` (because we let Unboxed win), +which led to #20746. Nowadays with `lubBoxity = boxedWins` we don't need +the complicated definition. Note [Demand type Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1780,39 +1960,46 @@ this has a strictness signature of <1L><1L>b meaning that we don't know what happens when we call err in weaker contexts than -C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We +C(1,C(1,L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (C(S,A)). We may not unleash the botDiv, hence assume topDiv. Of course, in -@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see +@err 1 2 `seq` ()@ the incoming demand C(S,C(S,A)) is strong enough and we see that the expression diverges. Now consider a function f g = g 1 2 -with signature , and the expression +with signature , and the expression f err `seq` () -now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed +now f puts a strictness demand of C(1,C(1,L)) onto its argument, which is unleashed on err via the App rule. In contrast to weaker head strictness, this demand is strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand env Equality] +Note [Demand type Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What is the difference between the Demand env {x->A} and {}? +What is the difference between the DmdType {x->A} and ? Answer: There is none! They have the exact same semantics, because any var that -is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on -the divergence of the demand env 'de_div'. -Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV -demand of BotDiv is B. But neither is equal to b{}, because y has demand B in +is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on +the divergence of the demand type 'dt_div'. +Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV +demand of BotDiv is B. But neither is equal to b, because y has demand B in the latter, not A as before. -The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity -issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...). -It does so by filtering out any default FV demands prior to comparing 'de_fvs'. +NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the +demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along +a 'Divergence', for example. -Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD', -involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the +The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity +issues during fixed-point iteration ({x->A} /= /= {x->A} /= ...). +It does so by filtering out any default FV demands prior to comparing 'dt_env'. +An alternative would be to maintain an invariant that there are no default FV demands +in 'dt_env' to begin with, but that seems more involved to maintain in the current +implementation. + +Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD', +involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the other. -Note [Asymmetry of plusDmdType] +Note [Asymmetry of 'plus*'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands! For example, given (e1 e2), we get @@ -1842,7 +2029,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, +e.g arising from "f x1 x2" in a strict, use-once context, then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for the free variable environment) and furthermore the result information r is the one we want to use. @@ -1850,9 +2037,9 @@ An anonymous lambda is also an unsaturated function all (needs one argument, none given), so this applies to that case as well. -But the demand fed into f might be less than C1(C1(L)). Then we have to +But the demand fed into f might be less than C(1,C(1,L)). Then we have to 'multDmdType' the announced demand type. Examples: - * Not strict enough, e.g. C1(C1(L)): + * Not strict enough, e.g. C(1,C(1,L)): - We have to multiply all argument and free variable demands with C_01, zapping strictness. - We have to multiply divergence with C_01. If r says that f Diverges for sure, @@ -1860,7 +2047,7 @@ be passed. If the demand is lower, we may just as well converge. If we were tracking definite convergence, than that would still hold under a weaker demand than expected by the demand transformer. - * Used more than once, e.g. CS(C1(L)): + * Used more than once, e.g. C(S,C(1,L)): - Multiply with C_1N. Even if f puts a used-once demand on any of its argument or free variables, if we call f multiple times, we may evaluate this argument or free variable multiple times. @@ -1889,8 +2076,8 @@ c) an indication of the result of applying the Id to its arguments -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely +However, in fact we store in the Id an extremely emasculated demand +transformer, namely a single DmdType (Nevertheless we dignify DmdSig as a distinct type.) @@ -1916,7 +2103,7 @@ uses x with 1L, and its arg with demand 1P(L,L). Note [Understanding DmdType and DmdSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to the incoming demand we put the expression under. Consider the following expression: @@ -1930,8 +2117,8 @@ incoming demand | demand type -------------------------------- 1A | {} - C1(C1(L)) | <1P(L)>{} - C1(C1(1P(1P(L),A))) | <1P(A)>{} + C(1,C(1,L)) | <1P(L)>{} + C(1,C(1,1P(1P(L),A))) | <1P(A)>{} Note that in the first example, the depth of the demand type was *higher* than the arity of the incoming call demand due to the anonymous lambda. @@ -1968,21 +2155,24 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig -mkDmdSigForArity arity dmd_ty@(DmdType fvs args) - | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) +mkDmdSigForArity arity dmd_ty@(DmdType fvs args div) + | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig -mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds) +mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res) +mkVanillaDmdSig :: Arity -> Divergence -> DmdSig +mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div + splitDmdSig :: DmdSig -> ([Demand], Divergence) -splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env) +splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res) dmdSigDmdEnv :: DmdSig -> DmdEnv -dmdSigDmdEnv (DmdSig (DmdType env _)) = env +dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env hasDemandEnvSig :: DmdSig -> Bool -hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv +hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv botSig :: DmdSig botSig = DmdSig botDmdType @@ -1991,16 +2181,23 @@ nopSig = DmdSig nopDmdType isNopSig :: DmdSig -> Bool -isNopSig (DmdSig ty) = ty == nopDmdType +isNopSig (DmdSig ty) = isNopDmdType ty -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool -isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env) +isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res +-- | True if the signature diverges or throws an imprecise exception in a saturated call. +-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'. +-- See Note [Dead ends] +-- and Note [Precise vs imprecise exceptions]. +isBottomingSig :: DmdSig -> Bool +isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv + -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool -onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds +onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds where demandIsBoxed BotDmd = True demandIsBoxed AbsDmd = True @@ -2020,29 +2217,59 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool -isDeadEndAppSig (DmdSig (DmdType env ds)) n - = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) - -trimBoxityDmdEnv :: DmdEnv -> DmdEnv -trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div +isDeadEndAppSig (DmdSig (DmdType _ ds res)) n + = isDeadEndDiv res && not (lengthExceeds ds n) trimBoxityDmdType :: DmdType -> DmdType -trimBoxityDmdType (DmdType env ds) = - DmdType (trimBoxityDmdEnv env) (map trimBoxity ds) +trimBoxityDmdType (DmdType fvs ds res) = + DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType +-- | Transfers the boxity of the left arg to the demand structure of the right +-- arg. This only makes sense if applied to new and old demands of the same +-- value. +transferBoxity :: Demand -> Demand -> Demand +transferBoxity from to = go_dmd from to + where + go_dmd (from_n :* from_sd) to_dmd@(to_n :* to_sd) + | isAbs from_n || isAbs to_n = to_dmd + | otherwise = case (from_sd, to_sd) of + (Poly from_b _, Poly _ to_c) -> + to_n :* Poly from_b to_c + (_, Prod _ to_ds) + | Just (from_b, from_ds) <- viewProd (length to_ds) from_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + (Prod from_b from_ds, _) + | Just (_, to_ds) <- viewProd (length from_ds) to_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + _ -> trimBoxity to_dmd + +transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType +transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res) + | equalLength from_ds to_ds + = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $ + DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper] + (zipWith transferBoxity from_ds to_ds) + to_res + | otherwise + = trimBoxityDmdType to + +transferArgBoxityDmdSig :: DmdSig -> DmdSig -> DmdSig +transferArgBoxityDmdSig = coerce transferArgBoxityDmdType + prependArgsDmdSig :: Int -> DmdSig -> DmdSig -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut. -prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds)) - | new_args == 0 = sig - | dmd_ty == nopDmdType = sig - | otherwise = DmdSig (DmdType env dmds') +prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) + | new_args == 0 = sig + | isNopDmdType dmd_ty = sig + | otherwise = DmdSig (DmdType env dmds' res) where - dmds' = replicate new_args topDmd ++ dmds + dmds' = assertPpr (new_args > 0) (ppr new_args) $ + replicate new_args topDmd ++ dmds etaConvertDmdSig :: Arity -> DmdSig -> DmdSig -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to @@ -2081,7 +2308,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer -dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd +dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] -- and Note [What are demand signatures?] @@ -2096,7 +2323,7 @@ where arity = length str_marks (n, body_sd) = peelManyCalls arity sd - mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) + mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) | otherwise = multDmd n dmd str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness] @@ -2107,11 +2334,11 @@ dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries. -- It should simply apply call_sd directly to the dictionary, I suppose. -dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd +dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd | (n, sd') <- peelCallDmd call_sd , Prod _ sig_ds <- prod = multDmdType n $ - DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] + DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where @@ -2162,7 +2389,7 @@ SubDemand --F_f----> DmdType With - α(C1(C1(_))) = >=2 + α(C(1,C(1,_))) = >=2 α(_) = <2 γ(ty) = ty and F_f being the abstract transformer of f's RHS and f_f being the abstracted @@ -2192,7 +2419,7 @@ What do we learn about the demand on 'd'? Alas, we see only the demand from 'sc_sel', namely '1P(1,A)'. We /don't/ see that 'd' really has a nested -demand '1P(1P(A,1C1(1)),A)'. On the other hand, if we inlined the two selectors +demand '1P(1P(A,1C(1,1)),A)'. On the other hand, if we inlined the two selectors we'd have f d x = case d of (x,_) -> @@ -2233,12 +2460,9 @@ it should not fall over. -} -zapDmdEnv :: DmdEnv -> DmdEnv -zapDmdEnv (DE _ div) = mkEmptyDmdEnv div - -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig -zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds) +zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand @@ -2259,8 +2483,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness -- signature zapUsedOnceSig :: DmdSig -> DmdSig -zapUsedOnceSig (DmdSig (DmdType env ds)) - = DmdSig (DmdType env (map zapUsedOnceDemand ds)) +zapUsedOnceSig (DmdSig (DmdType env ds r)) + = DmdSig (DmdType env (map zapUsedOnceDemand ds) r) data KillFlags = KillFlags { kf_abs :: Bool @@ -2345,11 +2569,11 @@ seqDemandList = foldr (seq . seqDemand) () seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds) = - seqDmdEnv env `seq` seqDemandList ds `seq` () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () seqDmdEnv :: DmdEnv -> () -seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs +seqDmdEnv env = seqEltsUFM seqDemand env seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty @@ -2441,8 +2665,8 @@ -- | See Note [Demand notation] instance Outputable SubDemand where - ppr (Poly b sd) = pp_boxity b <> ppr sd - ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd) + ppr (Poly b n) = pp_boxity b <> ppr n + ppr (Call n sd) = char 'C' <> parens (ppr n <> comma <> ppr sd) ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds) where fields [] = empty @@ -2458,20 +2682,17 @@ ppr ExnOrDiv = char 'x' -- for e(x)ception ppr Dunno = empty -instance Outputable DmdEnv where - ppr (DE fvs div) - = ppr div <> if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts)) +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] where pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fvs + fv_elts = nonDetUFMToList fv -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing -instance Outputable DmdType where - ppr (DmdType fv ds) - = hcat (map (angleBrackets . ppr) ds) <> ppr fv - instance Outputable DmdSig where ppr (DmdSig ty) = ppr ty @@ -2520,6 +2741,15 @@ 2 -> Prod <$> get bh <*> get bh _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) +instance Binary DmdSig where + put_ bh (DmdSig aa) = put_ bh aa + get bh = DmdSig <$> get bh + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr + get bh = DmdType emptyDmdEnv <$> get bh <*> get bh + instance Binary Divergence where put_ bh Dunno = putByte bh 0 put_ bh ExnOrDiv = putByte bh 1 @@ -2531,16 +2761,3 @@ 1 -> return ExnOrDiv 2 -> return Diverges _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int)) - -instance Binary DmdEnv where - -- Ignore VarEnv when spitting out the DmdType - put_ bh (DE _ d) = put_ bh d - get bh = DE emptyVarEnv <$> get bh - -instance Binary DmdType where - put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds - get bh = DmdType <$> get bh <*> get bh - -instance Binary DmdSig where - put_ bh (DmdSig aa) = put_ bh aa - get bh = DmdSig <$> get bh diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -4,6 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.Error ( -- * Messages @@ -23,6 +26,7 @@ , MessageClass (..) , Severity (..) , Diagnostic (..) + , UnknownDiagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) , DiagnosticHint (..) @@ -31,6 +35,8 @@ , mkDecoratedDiagnostic , mkDecoratedError + , NoDiagnosticOpts(..) + -- * Hints and refactoring actions , GhcHint (..) , AvailableBindings(..) @@ -54,7 +60,7 @@ , pprMessageBag , mkLocMessage - , mkLocMessageAnn + , mkLocMessageWarningGroups , getCaretDiagnostic -- * Queries , isIntrinsicErrorMessage @@ -65,6 +71,9 @@ , partitionMessages , errorsFound , errorsOrFatalWarningsFound + + -- * Diagnostic codes + , DiagnosticCode(..) ) where @@ -77,13 +86,19 @@ import GHC.Utils.Outputable as Outputable import qualified GHC.Utils.Ppr.Colour as Col import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Hint import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json +import GHC.Utils.Panic import Data.Bifunctor import Data.Foldable ( fold ) -import GHC.Types.Hint +import qualified Data.List.NonEmpty as NE +import Data.List ( intercalate ) +import Data.Typeable ( Typeable ) +import Numeric.Natural ( Natural ) +import Text.Printf ( printf ) {- Note [Messages] @@ -191,39 +206,6 @@ mapDecoratedSDoc f (Decorated s1) = Decorated (map f s1) -{- -Note [Rendering Messages] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Turning 'Messages' into something that renders nicely for the user is one of -the last steps, and it happens typically at the application's boundaries (i.e. -from the 'Driver' upwards). - -For now (see #18516) this class has few instance, but the idea is that as the -more domain-specific types are defined, the more instances we would get. For -example, given something like: - - data TcRnDiagnostic - = TcRnOutOfScope .. - | .. - - newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) - -We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather -than scattering pieces of 'SDoc' around the codebase, we would write once for -all: - - instance Diagnostic TcRnDiagnostic where - diagnosticMessage (TcRnMessage msg) = case diagMessage msg of - TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] - ... - -This way, we can easily write generic rendering functions for errors that all -they care about is the knowledge that a given type 'e' has a 'Diagnostic' -constraint. - --} - -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: -- @@ -232,16 +214,59 @@ -- -- A 'Diagnostic' carries the /actual/ description of the message (which, in -- GHC's case, it can be an error or a warning) and the /reason/ why such --- message was generated in the first place. See also Note [Rendering --- Messages]. +-- message was generated in the first place. class Diagnostic a where - diagnosticMessage :: a -> DecoratedSDoc + + -- | Type of configuration options for the diagnostic. + type DiagnosticOpts a + defaultDiagnosticOpts :: DiagnosticOpts a + + -- | Extract the error message text from a 'Diagnostic'. + diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc + + -- | Extract the reason for this diagnostic. For warnings, + -- a 'DiagnosticReason' includes the warning flag. diagnosticReason :: a -> DiagnosticReason + + -- | Extract any hints a user might use to repair their + -- code to avoid this diagnostic. diagnosticHints :: a -> [GhcHint] -pprDiagnostic :: Diagnostic e => e -> SDoc + -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'. + -- This can return 'Nothing' for at least two reasons: + -- + -- 1. The message might be from a plugin that does not supply codes. + -- 2. The message might not yet have been assigned a code. See the + -- 'Diagnostic' instance for 'DiagnosticMessage'. + -- + -- Ideally, case (2) would not happen, but because + -- some errors in GHC still use the old system of just writing the + -- error message in-place (instead of using a dedicated error type + -- and constructor), we do not have error codes for all errors. + -- #18516 tracks our progress toward this goal. + diagnosticCode :: a -> Maybe DiagnosticCode + +-- | An existential wrapper around an unknown diagnostic. +data UnknownDiagnostic where + UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) + => a -> UnknownDiagnostic + +instance Diagnostic UnknownDiagnostic where + type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ (UnknownDiagnostic diag) = diagnosticMessage NoDiagnosticOpts diag + diagnosticReason (UnknownDiagnostic diag) = diagnosticReason diag + diagnosticHints (UnknownDiagnostic diag) = diagnosticHints diag + diagnosticCode (UnknownDiagnostic diag) = diagnosticCode diag + +-- A fallback 'DiagnosticOpts' which can be used when there are no options +-- for a particular diagnostic. +data NoDiagnosticOpts = NoDiagnosticOpts + +pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e) - , nest 2 (vcat (unDecorated (diagnosticMessage e))) ] + , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ] + where opts = defaultDiagnosticOpts @e -- | A generic 'Hint' message, to be used with 'DiagnosticMessage'. data DiagnosticHint = DiagnosticHint !SDoc @@ -261,9 +286,12 @@ } instance Diagnostic DiagnosticMessage where - diagnosticMessage = diagMessage + type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = diagMessage diagnosticReason = diagReason diagnosticHints = diagHints + diagnosticCode _ = Nothing -- | Helper function to use when no hints can be provided. Currently this function -- can be used to construct plain 'DiagnosticMessage' and add hints to them, but @@ -323,7 +351,7 @@ data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order - , errMsgContext :: PrintUnqualified + , errMsgContext :: NamePprCtx , errMsgDiagnostic :: e , errMsgSeverity :: Severity } deriving (Functor, Foldable, Traversable) @@ -344,7 +372,7 @@ -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity DiagnosticReason + | MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode) -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -353,10 +381,15 @@ -- and manipulate diagnostic messages directly, for example inside -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when -- emitting compiler diagnostics, use the smart constructor. - deriving (Eq, Show) - -{- Note [Suppressing Messages] + -- + -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for + -- this diagnostic. If you are creating a message not tied to any + -- error-message type, then use Nothing. In the long run, this really + -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. +{- +Note [Suppressing Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'SevIgnore' constructor is used to generate messages for diagnostics which are meant to be suppressed and not reported to the user: the classic example are warnings for which the user didn't enable the corresponding 'WarningFlag', @@ -410,27 +443,31 @@ json MCInteractive = JSString "MCInteractive" json MCDump = JSString "MCDump" json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason) = - JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason) + json (MCDiagnostic sev reason code) = + JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope --- | Shows an 'MsgEnvelope'. -showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String +-- | Shows an 'MsgEnvelope'. Only use this for debugging. +showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String showMsgEnvelope err = - renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err)) + renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage (defaultDiagnosticOpts @a)) $ errMsgDiagnostic err)) pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an unannotated error message with location info. -mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc -mkLocMessage = mkLocMessageAnn Nothing +mkLocMessage + :: MessageClass -- ^ What kind of message? + -> SrcSpan -- ^ location + -> SDoc -- ^ message + -> SDoc +mkLocMessage = mkLocMessageWarningGroups True --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation +-- | Make an error message with location info, specifying whether to show +-- warning groups (if applicable). +mkLocMessageWarningGroups + :: Bool -- ^ Print warning groups (if applicable)? -> MessageClass -- ^ What kind of message? -> SrcSpan -- ^ location -> SDoc -- ^ message @@ -438,41 +475,76 @@ -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "". -mkLocMessageAnn ann msg_class locn msg +mkLocMessageWarningGroups show_warn_groups msg_class locn msg = sdocOption sdocColScheme $ \col_scheme -> let locn' = sdocOption sdocErrorSpans $ \case True -> ppr locn False -> ppr (srcSpanStart locn) - msgColour = getMessageClassColour msg_class col_scheme + msg_colour = getMessageClassColour msg_class col_scheme + col = coloured msg_colour . text - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured msgColour (text i) <> text "]" + msg_title = coloured msg_colour $ + case msg_class of + MCDiagnostic SevError _ _ -> text "error" + MCDiagnostic SevWarning _ _ -> text "warning" + MCFatal -> text "fatal" + _ -> empty + warning_flag_doc = + case msg_class of + MCDiagnostic sev reason _code + | Just msg <- flag_msg sev reason -> brackets msg + _ -> empty + + code_doc = + case msg_class of + MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code) + _ -> empty + + flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc + flag_msg SevIgnore _ = Nothing + -- The above can happen when displaying an error message + -- in a log file, e.g. with -ddump-tc-trace. It should not + -- happen otherwise, though. + flag_msg SevError WarningWithoutFlag = Just (col "-Werror") + flag_msg SevError (WarningWithFlag wflag) = + let name = NE.head (warnFlagNames wflag) in + Just $ col ("-W" ++ name) <+> warn_flag_grp wflag + <> comma + <+> col ("Werror=" ++ name) + flag_msg SevError ErrorWithoutFlag = Nothing + flag_msg SevWarning WarningWithoutFlag = Nothing + flag_msg SevWarning (WarningWithFlag wflag) = + let name = NE.head (warnFlagNames wflag) in + Just (col ("-W" ++ name) <+> warn_flag_grp wflag) + flag_msg SevWarning ErrorWithoutFlag = + pprPanic "SevWarning with ErrorWithoutFlag" $ + vcat [ text "locn:" <+> ppr locn + , text "msg:" <+> ppr msg ] + + warn_flag_grp flag + | show_warn_groups = + case smallestWarningGroups flag of + [] -> empty + groups -> text $ "(in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = empty + -- Add prefixes, like Foo.hs:34: warning: -- header = locn' <> colon <+> - coloured msgColour msgText <> optAnn + msg_title <> colon <+> + code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) (hang (coloured (Col.sHeader col_scheme) header) 4 msg) - where - msgText = - case msg_class of - MCDiagnostic SevError _reason -> text "error:" - MCDiagnostic SevWarning _reason -> text "warning:" - MCFatal -> text "fatal:" - _ -> empty - getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic SevError _reason) = Col.sError -getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty +getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError +getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning +getMessageClassColour MCFatal = Col.sFatal +getMessageClassColour _ = const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty @@ -602,3 +674,29 @@ -- warnings, and the second the errors. partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e) partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs) + +---------------------------------------------------------------- +-- -- +-- Definition of diagnostic codes -- +-- -- +---------------------------------------------------------------- + +-- | A diagnostic code is a namespaced numeric identifier +-- unique to the given diagnostic (error or warning). +-- +-- All diagnostic codes defined within GHC are given the +-- GHC namespace. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error.Codes. +data DiagnosticCode = + DiagnosticCode + { diagnosticCodeNameSpace :: String + -- ^ diagnostic code prefix (e.g. "GHC") + , diagnosticCodeNumber :: Natural + -- ^ the actual diagnostic code + } + +instance Outputable DiagnosticCode where + ppr (DiagnosticCode prefix c) = + text prefix <> text "-" <> text (printf "%05d" c) + -- pad the numeric code to have at least 5 digits diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Error/Codes.hs @@ -0,0 +1,903 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines diagnostic codes for the diagnostics emitted by GHC. +-- +-- A diagnostic code is a numeric unique identifier for a diagnostic. +-- See Note [Diagnostic codes]. +module GHC.Types.Error.Codes + ( constructorCode ) + where + +import GHC.Prelude +import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode ) + +import GHC.Hs.Extension ( GhcRn ) + +import GHC.Driver.Errors.Types ( DriverMessage ) +import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) +import GHC.Unit.Module.Warnings ( WarningTxt ) +import GHC.Utils.Panic.Plain + +import Data.Kind ( Type, Constraint ) +import GHC.Exts ( proxy# ) +import GHC.Generics +import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) +import GHC.TypeNats ( Nat, KnownNat, natVal' ) + +{- Note [Diagnostic codes] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every time a new diagnostic (error or warning) is introduced to GHC, +it is assigned a new numeric code, which has never been used before. + +To ensure uniqueness across GHC versions, we proceed as follows: + + - all diagnostic codes are defined in a single module, GHC.Types.Error.Codes. + - uniqueness of diagnostic codes is ensured by the use of an injective type family, + GhcDiagnosticCode, + - a diagnostic code never gets deleted from the GhcDiagnosticCode type family + in GHC.Types.Error.Codes, even if it is no longer used. + Older versions of GHC might still display the code, and we don't want that + old code to get confused with the error code of a different, new, error message. + +[Instructions for adding a new diagnostic code] + + After adding a constructor to a diagnostic datatype, such as PsMessage, + TcRnMessage, DsMessage or DriverMessage, you can add corresponding + diagnostic codes as follows: + + a. To give a single diagnostic code to the constructor, simply add a + type family equation to GHC.Error.Codes.GhcDiagnosticCode, e.g.: + + GhcDiagnosticCode "MyNewErrorConstructor" = 12345 + + You can obtain new randomly-generated error codes by using + https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain. + + You will get a type error if you try to use an error code that is already + used by another constructor. + + b. If you instead require more granular diagnostic codes, add a type family + equation to GHC.Error.Codes.ConRecursInto, specifying which argument + to recur into to obtain an diagnostic code. + + For example, the 'TcRnCannotDeriveInstance' constructor is associated + with several diagnostic codes, depending on the value of the argument of + type 'DeriveInstanceErrReason'. This is achieved as follows: + + - The equation + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + says to recur into the argument of type 'DeriveInstanceErrReason' + to get a diagnostic code. + + - The equations + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + ... + give the diagnostic codes for the various constructors of DeriveInstanceErrReason. + These are added following the procedure in (a). + + Never remove a return value from the 'GhcDiagnosticCode' type family! + Outdated error messages must still be tracked to ensure uniqueness + of diagnostic codes across GHC versions. +-} + +{- ********************************************************************* +* * + The GhcDiagnosticCode type family +* * +********************************************************************* -} + +-- | This function obtain a diagnostic code by looking up the constructor +-- name using generics, and using the 'GhcDiagnosticCode' type family. +constructorCode :: (Generic diag, GDiagnosticCode (Rep diag)) + => diag -> Maybe DiagnosticCode +constructorCode diag = gdiagnosticCode (from diag) + +-- | Type family computing the numeric diagnostic code for a given error message constructor. +-- +-- Its injectivity annotation ensures uniqueness of error codes. +-- +-- Never remove a return value from this type family! Outdated error messages must still +-- be tracked here to ensure uniqueness of diagnostic codes across GHC versions. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error. +type GhcDiagnosticCode :: Symbol -> Nat +type family GhcDiagnosticCode c = n | n -> c where + + -- Desugarer diagnostic codes + GhcDiagnosticCode "DsEmptyEnumeration" = 10190 + GhcDiagnosticCode "DsIdentitiesFound" = 04214 + GhcDiagnosticCode "DsOverflowedLiterals" = 97441 + GhcDiagnosticCode "DsRedundantBangPatterns" = 38520 + GhcDiagnosticCode "DsOverlappingPatterns" = 53633 + GhcDiagnosticCode "DsInaccessibleRhs" = 94210 + GhcDiagnosticCode "DsMaxPmCheckModelsReached" = 61505 + GhcDiagnosticCode "DsNonExhaustivePatterns" = 62161 + GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099 + GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector" = 93315 + GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction" = 38524 + GhcDiagnosticCode "DsMultiplicityCoercionsNotSupported" = 59840 + GhcDiagnosticCode "DsOrphanRule" = 58181 + GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441 + GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828 + GhcDiagnosticCode "DsRuleBindersNotBound" = 40548 + GhcDiagnosticCode "DsLazyPatCantBindVarsOfUnliftedType" = 17879 + GhcDiagnosticCode "DsNotYetHandledByTH" = 65904 + GhcDiagnosticCode "DsAggregatedViewExpressions" = 19551 + GhcDiagnosticCode "DsUnbangedStrictPatterns" = 21030 + GhcDiagnosticCode "DsCannotMixPolyAndUnliftedBindings" = 20036 + GhcDiagnosticCode "DsWrongDoBind" = 08838 + GhcDiagnosticCode "DsUnusedDoBind" = 81995 + GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185 + GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396 + GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502 + + + -- Parser diagnostic codes + GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686 + GhcDiagnosticCode "PsErrUnsupportedExt" = 46537 + GhcDiagnosticCode "PsErrParseOptionsPragma" = 24342 + GhcDiagnosticCode "PsErrUnknownOptionsPragma" = 04924 + GhcDiagnosticCode "PsWarnBidirectionalFormatChars" = 03272 + GhcDiagnosticCode "PsWarnTab" = 94817 + GhcDiagnosticCode "PsWarnTransitionalLayout" = 93617 + GhcDiagnosticCode "PsWarnOperatorWhitespaceExtConflict" = 47082 + GhcDiagnosticCode "PsWarnOperatorWhitespace" = 40798 + GhcDiagnosticCode "PsWarnHaddockInvalidPos" = 94458 + GhcDiagnosticCode "PsWarnHaddockIgnoreMulti" = 05641 + GhcDiagnosticCode "PsWarnStarBinder" = 21887 + GhcDiagnosticCode "PsWarnStarIsType" = 39567 + GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 + GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 + GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsErrLexer" = 21231 + GhcDiagnosticCode "PsErrCmmLexer" = 75725 + GhcDiagnosticCode "PsErrCmmParser" = 09848 + GhcDiagnosticCode "PsErrParse" = 58481 + GhcDiagnosticCode "PsErrTypeAppWithoutSpace" = 84077 + GhcDiagnosticCode "PsErrLazyPatWithoutSpace" = 27207 + GhcDiagnosticCode "PsErrBangPatWithoutSpace" = 95644 + GhcDiagnosticCode "PsErrInvalidInfixHole" = 45106 + GhcDiagnosticCode "PsErrExpectedHyphen" = 44524 + GhcDiagnosticCode "PsErrSpaceInSCC" = 76176 + GhcDiagnosticCode "PsErrEmptyDoubleQuotes" = 11861 + GhcDiagnosticCode "PsErrLambdaCase" = 51179 + GhcDiagnosticCode "PsErrEmptyLambda" = 71614 + GhcDiagnosticCode "PsErrLinearFunction" = 31574 + GhcDiagnosticCode "PsErrMultiWayIf" = 28985 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNotEnabled" = 82135 + GhcDiagnosticCode "PsErrNumUnderscores" = 62330 + GhcDiagnosticCode "PsErrIllegalBangPattern" = 79767 + GhcDiagnosticCode "PsErrOverloadedRecordDotInvalid" = 26832 + GhcDiagnosticCode "PsErrIllegalPatSynExport" = 89515 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNoQualifiedFields" = 94863 + GhcDiagnosticCode "PsErrExplicitForall" = 25955 + GhcDiagnosticCode "PsErrIllegalQualifiedDo" = 40280 + GhcDiagnosticCode "PsErrQualifiedDoInCmd" = 54089 + GhcDiagnosticCode "PsErrRecordSyntaxInPatSynDecl" = 28021 + GhcDiagnosticCode "PsErrEmptyWhereInPatSynDecl" = 13248 + GhcDiagnosticCode "PsErrInvalidWhereBindInPatSynDecl" = 24737 + GhcDiagnosticCode "PsErrNoSingleWhereBindInPatSynDecl" = 65536 + GhcDiagnosticCode "PsErrDeclSpliceNotAtTopLevel" = 08451 + GhcDiagnosticCode "PsErrMultipleNamesInStandaloneKindSignature" = 42569 + GhcDiagnosticCode "PsErrIllegalExplicitNamespace" = 47007 + GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 + GhcDiagnosticCode "PsErrImportPostQualified" = 87491 + GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 + GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 + GhcDiagnosticCode "PsErrMissingBlock" = 16849 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumExpr" = 09550 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumPat" = 16863 + GhcDiagnosticCode "PsErrUnexpectedQualifiedConstructor" = 73413 + GhcDiagnosticCode "PsErrTupleSectionInPat" = 09646 + GhcDiagnosticCode "PsErrOpFewArgs" = 24180 + GhcDiagnosticCode "PsErrVarForTyCon" = 18208 + GhcDiagnosticCode "PsErrMalformedEntityString" = 26204 + GhcDiagnosticCode "PsErrDotsInRecordUpdate" = 70712 + GhcDiagnosticCode "PsErrInvalidDataCon" = 46574 + GhcDiagnosticCode "PsErrInvalidInfixDataCon" = 30670 + GhcDiagnosticCode "PsErrIllegalPromotionQuoteDataCon" = 80236 + GhcDiagnosticCode "PsErrUnpackDataCon" = 40845 + GhcDiagnosticCode "PsErrUnexpectedKindAppInDataCon" = 83653 + GhcDiagnosticCode "PsErrInvalidRecordCon" = 08195 + GhcDiagnosticCode "PsErrIllegalUnboxedStringInPat" = 69925 + GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat" = 76595 + GhcDiagnosticCode "PsErrDoNotationInPat" = 06446 + GhcDiagnosticCode "PsErrIfThenElseInPat" = 45696 + GhcDiagnosticCode "PsErrLambdaCaseInPat" = 07636 + GhcDiagnosticCode "PsErrCaseInPat" = 53786 + GhcDiagnosticCode "PsErrLetInPat" = 78892 + GhcDiagnosticCode "PsErrLambdaInPat" = 00482 + GhcDiagnosticCode "PsErrArrowExprInPat" = 04584 + GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980 + GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043 + GhcDiagnosticCode "PsErrViewPatInExpr" = 66228 + GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178 + GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971 + GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = 47171 + GhcDiagnosticCode "PsErrIfCmdInFunAppCmd" = 97005 + GhcDiagnosticCode "PsErrLetCmdInFunAppCmd" = 70526 + GhcDiagnosticCode "PsErrDoCmdInFunAppCmd" = 77808 + GhcDiagnosticCode "PsErrDoInFunAppExpr" = 52095 + GhcDiagnosticCode "PsErrMDoInFunAppExpr" = 67630 + GhcDiagnosticCode "PsErrLambdaInFunAppExpr" = 06074 + GhcDiagnosticCode "PsErrCaseInFunAppExpr" = 25037 + GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = 77182 + GhcDiagnosticCode "PsErrLetInFunAppExpr" = 90355 + GhcDiagnosticCode "PsErrIfInFunAppExpr" = 01239 + GhcDiagnosticCode "PsErrProcInFunAppExpr" = 04807 + GhcDiagnosticCode "PsErrMalformedTyOrClDecl" = 47568 + GhcDiagnosticCode "PsErrIllegalWhereInDataDecl" = 36952 + GhcDiagnosticCode "PsErrIllegalDataTypeContext" = 87429 + GhcDiagnosticCode "PsErrPrimStringInvalidChar" = 43080 + GhcDiagnosticCode "PsErrSuffixAT" = 33856 + GhcDiagnosticCode "PsErrPrecedenceOutOfRange" = 25078 + GhcDiagnosticCode "PsErrSemiColonsInCondExpr" = 75254 + GhcDiagnosticCode "PsErrSemiColonsInCondCmd" = 18910 + GhcDiagnosticCode "PsErrAtInPatPos" = 08382 + GhcDiagnosticCode "PsErrParseErrorOnInput" = 66418 + GhcDiagnosticCode "PsErrMalformedDecl" = 85316 + GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054 + GhcDiagnosticCode "PsErrNotADataCon" = 25742 + GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed" = 57342 + GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax" = 65719 + GhcDiagnosticCode "PsErrParseErrorInCmd" = 03790 + GhcDiagnosticCode "PsErrInPat" = 07626 + GhcDiagnosticCode "PsErrIllegalRoleName" = 09009 + GhcDiagnosticCode "PsErrInvalidTypeSignature" = 94426 + GhcDiagnosticCode "PsErrUnexpectedTypeInDecl" = 77878 + GhcDiagnosticCode "PsErrInvalidPackageName" = 21926 + GhcDiagnosticCode "PsErrParseRightOpSectionInPat" = 72516 + GhcDiagnosticCode "PsErrIllegalGadtRecordMultiplicity" = 37475 + GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 + GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380 + GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623 + + -- Driver diagnostic codes + GhcDiagnosticCode "DriverMissingHomeModules" = 32850 + GhcDiagnosticCode "DriverUnknownHiddenModules" = 38189 + GhcDiagnosticCode "DriverUnknownReexportedModules" = 68286 + GhcDiagnosticCode "DriverUnusedPackages" = 42258 + GhcDiagnosticCode "DriverUnnecessarySourceImports" = 88907 + GhcDiagnosticCode "DriverDuplicatedModuleDeclaration" = 29235 + GhcDiagnosticCode "DriverModuleNotFound" = 82272 + GhcDiagnosticCode "DriverFileModuleNameMismatch" = 28623 + GhcDiagnosticCode "DriverUnexpectedSignature" = 66004 + GhcDiagnosticCode "DriverFileNotFound" = 49196 + GhcDiagnosticCode "DriverStaticPointersNotSupported" = 77799 + GhcDiagnosticCode "DriverBackpackModuleNotFound" = 19971 + GhcDiagnosticCode "DriverUserDefinedRuleIgnored" = 56147 + GhcDiagnosticCode "DriverMixedSafetyImport" = 70172 + GhcDiagnosticCode "DriverCannotLoadInterfaceFile" = 37141 + GhcDiagnosticCode "DriverInferredSafeModule" = 58656 + GhcDiagnosticCode "DriverMarkedTrustworthyButInferredSafe" = 19244 + GhcDiagnosticCode "DriverInferredSafeImport" = 82658 + GhcDiagnosticCode "DriverCannotImportUnsafeModule" = 44360 + GhcDiagnosticCode "DriverMissingSafeHaskellMode" = 29747 + GhcDiagnosticCode "DriverPackageNotTrusted" = 08674 + GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 + GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 + GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + + -- Constraint solver diagnostic codes + GhcDiagnosticCode "BadTelescope" = 97739 + GhcDiagnosticCode "UserTypeError" = 64725 + GhcDiagnosticCode "ReportHoleError" = 88464 + GhcDiagnosticCode "UntouchableVariable" = 34699 + GhcDiagnosticCode "FixedRuntimeRepError" = 55287 + GhcDiagnosticCode "BlockedEquality" = 06200 + GhcDiagnosticCode "ExpectingMoreArguments" = 81325 + GhcDiagnosticCode "UnboundImplicitParams" = 91416 + GhcDiagnosticCode "AmbiguityPreventsSolvingCt" = 78125 + GhcDiagnosticCode "CannotResolveInstance" = 39999 + GhcDiagnosticCode "OverlappingInstances" = 43085 + GhcDiagnosticCode "UnsafeOverlap" = 36705 + + -- Type mismatch errors + GhcDiagnosticCode "BasicMismatch" = 18872 + GhcDiagnosticCode "KindMismatch" = 89223 + GhcDiagnosticCode "TypeEqMismatch" = 83865 + GhcDiagnosticCode "CouldNotDeduce" = 05617 + + -- Variable unification errors + GhcDiagnosticCode "CannotUnifyWithPolytype" = 91028 + GhcDiagnosticCode "OccursCheck" = 27958 + GhcDiagnosticCode "SkolemEscape" = 46956 + GhcDiagnosticCode "DifferentTyVars" = 25897 + GhcDiagnosticCode "RepresentationalEq" = 10283 + + -- Typechecker/renamer diagnostic codes + GhcDiagnosticCode "TcRnRedundantConstraints" = 30606 + GhcDiagnosticCode "TcRnInaccessibleCode" = 40564 + GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep" = 18478 + GhcDiagnosticCode "TcRnImplicitLift" = 00846 + GhcDiagnosticCode "TcRnUnusedPatternBinds" = 61367 + GhcDiagnosticCode "TcRnDodgyImports" = 99623 + GhcDiagnosticCode "TcRnDodgyExports" = 75356 + GhcDiagnosticCode "TcRnMissingImportList" = 77037 + GhcDiagnosticCode "TcRnUnsafeDueToPlugin" = 01687 + GhcDiagnosticCode "TcRnModMissingRealSrcSpan" = 84170 + GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188 + GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058 + GhcDiagnosticCode "TcRnShadowedName" = 63397 + GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711 + GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822 + GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077 + GhcDiagnosticCode "TcRnLinearPatSyn" = 15172 + GhcDiagnosticCode "TcRnEmptyRecordUpdate" = 20825 + GhcDiagnosticCode "TcRnIllegalFieldPunning" = 44287 + GhcDiagnosticCode "TcRnIllegalWildcardsInRecord" = 37132 + GhcDiagnosticCode "TcRnIllegalWildcardInType" = 65507 + GhcDiagnosticCode "TcRnDuplicateFieldName" = 85524 + GhcDiagnosticCode "TcRnIllegalViewPattern" = 22406 + GhcDiagnosticCode "TcRnCharLiteralOutOfRange" = 17268 + GhcDiagnosticCode "TcRnIllegalWildcardsInConstructor" = 47217 + GhcDiagnosticCode "TcRnIgnoringAnnotations" = 66649 + GhcDiagnosticCode "TcRnAnnotationInSafeHaskell" = 68934 + GhcDiagnosticCode "TcRnInvalidTypeApplication" = 95781 + GhcDiagnosticCode "TcRnTagToEnumMissingValArg" = 36495 + GhcDiagnosticCode "TcRnTagToEnumUnspecifiedResTy" = 08522 + GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 + GhcDiagnosticCode "TcRnTagToEnumResTyTypeData" = 96189 + GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 + GhcDiagnosticCode "TcRnIllegalHsBootFileDecl" = 58195 + GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 + GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch" = 88793 + GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier" = 94185 + GhcDiagnosticCode "TcRnMissingSignature" = 38417 + GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig" = 64414 + GhcDiagnosticCode "TcRnOverloadedSig" = 16675 + GhcDiagnosticCode "TcRnTupleConstraintInst" = 69012 + GhcDiagnosticCode "TcRnAbstractClassInst" = 51758 + GhcDiagnosticCode "TcRnNoClassInstHead" = 56538 + GhcDiagnosticCode "TcRnUserTypeError" = 47403 + GhcDiagnosticCode "TcRnConstraintInKind" = 01259 + GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg" = 19590 + GhcDiagnosticCode "TcRnLinearFuncInKind" = 13218 + GhcDiagnosticCode "TcRnForAllEscapeError" = 31147 + GhcDiagnosticCode "TcRnVDQInTermType" = 51580 + GhcDiagnosticCode "TcRnBadQuantPredHead" = 02550 + GhcDiagnosticCode "TcRnIllegalTupleConstraint" = 77539 + GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint" = 80003 + GhcDiagnosticCode "TcRnIllegalImplicitParam" = 75863 + GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind" = 75844 + GhcDiagnosticCode "TcRnIllegalClassInst" = 53946 + GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg" = 45474 + GhcDiagnosticCode "TcRnBadAssociatedType" = 38351 + GhcDiagnosticCode "TcRnForAllRankErr" = 91510 + GhcDiagnosticCode "TcRnMonomorphicBindings" = 55524 + GhcDiagnosticCode "TcRnOrphanInstance" = 90177 + GhcDiagnosticCode "TcRnFunDepConflict" = 46208 + GhcDiagnosticCode "TcRnDupInstanceDecls" = 59692 + GhcDiagnosticCode "TcRnConflictingFamInstDecls" = 34447 + GhcDiagnosticCode "TcRnFamInstNotInjective" = 05175 + GhcDiagnosticCode "TcRnBangOnUnliftedType" = 55666 + GhcDiagnosticCode "TcRnLazyBangOnUnliftedType" = 71444 + GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 + GhcDiagnosticCode "TcRnBadDefaultType" = 88933 + GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon" = 66775 + GhcDiagnosticCode "TcRnPatSynBundledWithWrongType" = 66025 + GhcDiagnosticCode "TcRnDupeModuleExport" = 51876 + GhcDiagnosticCode "TcRnExportedModNotImported" = 90973 + GhcDiagnosticCode "TcRnNullExportedModule" = 64649 + GhcDiagnosticCode "TcRnMissingExportList" = 85401 + GhcDiagnosticCode "TcRnExportHiddenComponents" = 94558 + GhcDiagnosticCode "TcRnDuplicateExport" = 47854 + GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnConflictingExports" = 69158 + GhcDiagnosticCode "TcRnAmbiguousField" = 02256 + GhcDiagnosticCode "TcRnMissingFields" = 20125 + GhcDiagnosticCode "TcRnFieldUpdateInvalidType" = 63055 + GhcDiagnosticCode "TcRnNoConstructorHasAllFields" = 14392 + GhcDiagnosticCode "TcRnMixedSelectors" = 40887 + GhcDiagnosticCode "TcRnMissingStrictFields" = 95909 + GhcDiagnosticCode "TcRnNoPossibleParentForFields" = 33238 + GhcDiagnosticCode "TcRnBadOverloadedRecordUpdate" = 99339 + GhcDiagnosticCode "TcRnStaticFormNotClosed" = 88431 + GhcDiagnosticCode "TcRnUselessTypeable" = 90584 + GhcDiagnosticCode "TcRnDerivingDefaults" = 20042 + GhcDiagnosticCode "TcRnNonUnaryTypeclassConstraint" = 73993 + GhcDiagnosticCode "TcRnPartialTypeSignatures" = 60661 + GhcDiagnosticCode "TcRnLazyGADTPattern" = 87005 + GhcDiagnosticCode "TcRnArrowProcGADTPattern" = 64525 + GhcDiagnosticCode "TcRnSpecialClassInst" = 97044 + GhcDiagnosticCode "TcRnForallIdentifier" = 64088 + GhcDiagnosticCode "TcRnTypeEqualityOutOfScope" = 12003 + GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators" = 58520 + GhcDiagnosticCode "TcRnIllegalTypeOperator" = 62547 + GhcDiagnosticCode "TcRnGADTMonoLocalBinds" = 58008 + GhcDiagnosticCode "TcRnIncorrectNameSpace" = 31891 + GhcDiagnosticCode "TcRnNoRebindableSyntaxRecordDot" = 65945 + GhcDiagnosticCode "TcRnNoFieldPunsRecordDot" = 57365 + GhcDiagnosticCode "TcRnIllegalStaticExpression" = 23800 + GhcDiagnosticCode "TcRnIllegalStaticFormInSplice" = 12219 + GhcDiagnosticCode "TcRnListComprehensionDuplicateBinding" = 81232 + GhcDiagnosticCode "TcRnLastStmtNotExpr" = 55814 + GhcDiagnosticCode "TcRnUnexpectedStatementInContext" = 42026 + GhcDiagnosticCode "TcRnSectionWithoutParentheses" = 95880 + GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings" = 50730 + GhcDiagnosticCode "TcRnIllegalTupleSection" = 59155 + + GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 + GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 + GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 + GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 + GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 + GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 + GhcDiagnosticCode "TcRnFunPtrImportWithoutAmpersand" = 57989 + GhcDiagnosticCode "TcRnIllegalForeignDeclBackend" = 03355 + GhcDiagnosticCode "TcRnUnsupportedCallConv" = 01245 + GhcDiagnosticCode "TcRnInvalidCIdentifier" = 95774 + GhcDiagnosticCode "TcRnExpectedValueId" = 01570 + GhcDiagnosticCode "TcRnNotARecordSelector" = 47535 + GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar" = 55876 + GhcDiagnosticCode "TcRnPatSynNotBidirectional" = 16444 + GhcDiagnosticCode "TcRnSplicePolymorphicLocalVar" = 06568 + GhcDiagnosticCode "TcRnIllegalDerivingItem" = 11913 + GhcDiagnosticCode "TcRnUnexpectedAnnotation" = 18932 + GhcDiagnosticCode "TcRnIllegalRecordSyntax" = 89246 + GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = 39180 + GhcDiagnosticCode "TcRnInvalidVisibleKindArgument" = 20967 + GhcDiagnosticCode "TcRnTooManyBinders" = 05989 + GhcDiagnosticCode "TcRnDifferentNamesForTyVar" = 17370 + GhcDiagnosticCode "TcRnInvalidReturnKind" = 55233 + GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 + GhcDiagnosticCode "TcRnUnpromotableThing" = 88634 + GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 + GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig" = 46131 + GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind" = 48361 + GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = 01629 + GhcDiagnosticCode "TcRnMultipleInlinePragmas" = 96665 + GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293 + GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827 + GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337 + GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 + GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 + GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 + + GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 + GhcDiagnosticCode "TcRnBadGenericMethod" = 59794 + GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511 + GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding" = 28587 + GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod" = 72520 + GhcDiagnosticCode "TcRnBadMethodErr" = 46284 + GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration" = 08585 + GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 + GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 + GhcDiagnosticCode "TcRnTypedTHWithPolyType" = 94642 + GhcDiagnosticCode "TcRnSpliceThrewException" = 87897 + GhcDiagnosticCode "TcRnInvalidTopDecl" = 52886 + GhcDiagnosticCode "TcRnNonExactName" = 77923 + GhcDiagnosticCode "TcRnAddInvalidCorePlugin" = 86463 + GhcDiagnosticCode "TcRnAddDocToNonLocalDefn" = 67760 + GhcDiagnosticCode "TcRnFailedToLookupThInstName" = 49530 + GhcDiagnosticCode "TcRnCannotReifyInstance" = 30384 + GhcDiagnosticCode "TcRnCannotReifyOutOfScopeThing" = 24922 + GhcDiagnosticCode "TcRnCannotReifyThingNotInTypeEnv" = 79890 + GhcDiagnosticCode "TcRnNoRolesAssociatedWithThing" = 65923 + GhcDiagnosticCode "TcRnCannotRepresentType" = 75721 + GhcDiagnosticCode "TcRnReportCustomQuasiError" = 39584 + GhcDiagnosticCode "TcRnInterfaceLookupError" = 52243 + GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef" = 06201 + GhcDiagnosticCode "TcRnMisplacedInstSig" = 06202 + GhcDiagnosticCode "TcRnBadBootFamInstDecl" = 06203 + GhcDiagnosticCode "TcRnIllegalFamilyInstance" = 06204 + GhcDiagnosticCode "TcRnMissingClassAssoc" = 06205 + GhcDiagnosticCode "TcRnBadFamInstDecl" = 06206 + GhcDiagnosticCode "TcRnNotOpenFamily" = 06207 + GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038 + + -- IllegalNewtypeReason + GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 + GhcDiagnosticCode "IsNonLinear" = 38291 + GhcDiagnosticCode "IsGADT" = 89498 + GhcDiagnosticCode "HasConstructorContext" = 17440 + GhcDiagnosticCode "HasExistentialTyVar" = 07525 + GhcDiagnosticCode "HasStrictnessAnnotation" = 04049 + + -- TcRnPragmaWarning + GhcDiagnosticCode "WarningTxt" = 63394 + GhcDiagnosticCode "DeprecatedTxt" = 68441 + + -- TcRnRunSliceFailure/ConversionFail + GhcDiagnosticCode "IllegalOccName" = 55017 + GhcDiagnosticCode "SumAltArityExceeded" = 68444 + GhcDiagnosticCode "IllegalSumAlt" = 63966 + GhcDiagnosticCode "IllegalSumArity" = 97721 + GhcDiagnosticCode "MalformedType" = 28709 + GhcDiagnosticCode "IllegalLastStatement" = 47373 + GhcDiagnosticCode "KindSigsOnlyAllowedOnGADTs" = 40746 + GhcDiagnosticCode "IllegalDeclaration" = 23882 + GhcDiagnosticCode "CannotMixGADTConsWith98Cons" = 24104 + GhcDiagnosticCode "EmptyStmtListInDoBlock" = 34949 + GhcDiagnosticCode "NonVarInInfixExpr" = 99831 + GhcDiagnosticCode "MultiWayIfWithoutAlts" = 63930 + GhcDiagnosticCode "CasesExprWithoutAlts" = 91745 + GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974 + GhcDiagnosticCode "InvalidCCallImpent" = 60220 + GhcDiagnosticCode "RecGadtNoCons" = 18816 + GhcDiagnosticCode "GadtNoCons" = 38140 + GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056 + GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486 + GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 + GhcDiagnosticCode "DefaultDataInstDecl" = 39639 + GhcDiagnosticCode "FunBindLacksEquations" = 52078 + + -- Diagnostic codes for the foreign function interface + GhcDiagnosticCode "NotADataType" = 31136 + GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 + GhcDiagnosticCode "UnliftedFFITypesNeeded" = 10964 + GhcDiagnosticCode "NotABoxedMarshalableTyCon" = 89401 + GhcDiagnosticCode "ForeignLabelNotAPtr" = 26070 + GhcDiagnosticCode "NotSimpleUnliftedType" = 43510 + GhcDiagnosticCode "NotBoxedKindAny" = 64097 + GhcDiagnosticCode "ForeignDynNotPtr" = 27555 + GhcDiagnosticCode "SafeHaskellMustBeInIO" = 57638 + GhcDiagnosticCode "IOResultExpected" = 41843 + GhcDiagnosticCode "UnexpectedNestedForall" = 92994 + GhcDiagnosticCode "LinearTypesNotAllowed" = 57396 + GhcDiagnosticCode "OneArgExpected" = 91490 + GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + + -- Out of scope errors + GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NoExactName" = 97784 + GhcDiagnosticCode "SameName" = 81573 + GhcDiagnosticCode "MissingBinding" = 44432 + GhcDiagnosticCode "NoTopLevelBinding" = 10173 + GhcDiagnosticCode "UnknownSubordinate" = 54721 + + -- Diagnostic codes for deriving + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + GhcDiagnosticCode "DerivErrNoEtaReduce" = 38996 + GhcDiagnosticCode "DerivErrBootFileFound" = 30903 + GhcDiagnosticCode "DerivErrDataConsNotAllInScope" = 54540 + GhcDiagnosticCode "DerivErrGNDUsedOnData" = 10333 + GhcDiagnosticCode "DerivErrNullaryClasses" = 04956 + GhcDiagnosticCode "DerivErrLastArgMustBeApp" = 28323 + GhcDiagnosticCode "DerivErrNoFamilyInstance" = 82614 + GhcDiagnosticCode "DerivErrNotStockDeriveable" = 00158 + GhcDiagnosticCode "DerivErrHasAssociatedDatatypes" = 34611 + GhcDiagnosticCode "DerivErrNewtypeNonDeriveableClass" = 82023 + GhcDiagnosticCode "DerivErrCannotEtaReduceEnough" = 26557 + GhcDiagnosticCode "DerivErrOnlyAnyClassDeriveable" = 23244 + GhcDiagnosticCode "DerivErrNotDeriveable" = 38178 + GhcDiagnosticCode "DerivErrNotAClass" = 63388 + GhcDiagnosticCode "DerivErrNoConstructors" = 64560 + GhcDiagnosticCode "DerivErrLangExtRequired" = 86639 + GhcDiagnosticCode "DerivErrDunnoHowToDeriveForType" = 48959 + GhcDiagnosticCode "DerivErrMustBeEnumType" = 30750 + GhcDiagnosticCode "DerivErrMustHaveExactlyOneConstructor" = 37542 + GhcDiagnosticCode "DerivErrMustHaveSomeParameters" = 45539 + GhcDiagnosticCode "DerivErrMustNotHaveClassContext" = 16588 + GhcDiagnosticCode "DerivErrBadConstructor" = 16437 + GhcDiagnosticCode "DerivErrGenerics" = 30367 + GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291 + + -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason + GhcDiagnosticCode "EmptyStmtsGroupInParallelComp" = 41242 + GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp" = 92693 + GhcDiagnosticCode "EmptyStmtsGroupInDoNotation" = 82311 + GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation" = 19442 + + -- To generate new random numbers: + -- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain + -- + -- NB: never remove a return value from this type family! + -- We need to ensure uniquess of diagnostic codes across GHC versions, + -- and this includes outdated diagnostic codes for errors that GHC + -- no longer reports. These are collected below. + + GhcDiagnosticCode "Example outdated error" = 00000 + +{- ********************************************************************* +* * + Recurring into an argument +* * +********************************************************************* -} + +-- | Some constructors of diagnostic datatypes don't have +-- corresponding error codes, because we recur inside them. +-- +-- For example, we don't have an error code for the +-- 'TcRnCannotDeriveInstance' constructor of 'TcRnMessage', +-- because we recur into the 'DeriveInstanceErrReason' to obtain +-- an error code. +-- +-- This type family keeps track of such constructors. +type ConRecursInto :: Symbol -> Maybe Type +type family ConRecursInto con where + + ---------------------------------- + -- Constructors of GhcMessage + + ConRecursInto "GhcDriverMessage" = 'Just DriverMessage + ConRecursInto "GhcPsMessage" = 'Just PsMessage + ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage + ConRecursInto "GhcDsMessage" = 'Just DsMessage + ConRecursInto "GhcUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Constructors of DriverMessage + + ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + + ---------------------------------- + -- Constructors of PsMessage + + ConRecursInto "PsUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage + + ---------------------------------- + -- Constructors of TcRnMessage + + ConRecursInto "TcRnUnknownMessage" = 'Just UnknownDiagnostic + + -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage + ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed + ConRecursInto "TcRnMessageDetailed" = 'Just TcRnMessage + ConRecursInto "TcRnWithHsDocContext" = 'Just TcRnMessage + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn) + ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError + ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason + + -- + -- TH errors + + ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason + ConRecursInto "ConversionFail" = 'Just ConversionFailReason + + ------------------ + -- FFI errors + + ConRecursInto "TcRnIllegalForeignType" = 'Just IllegalForeignTypeReason + -- IllegalForeignTypeReason: recur into TypeCannotBeMarshaled for the reason + ConRecursInto "TypeCannotBeMarshaled" = 'Just TypeCannotBeMarshaledReason + + ------------------ + -- Solver reports + + -- Recur inside TcRnSolverReport to get the underlying TcSolverReportMsg + ConRecursInto "TcRnSolverReport" = 'Just SolverReportWithCtxt + ConRecursInto "SolverReportWithCtxt" = 'Just TcSolverReportMsg + ConRecursInto "TcReportWithInfo" = 'Just TcSolverReportMsg + + -- Recur inside CannotUnifyVariable to get the underlying reason + ConRecursInto "CannotUnifyVariable" = 'Just CannotUnifyVariableReason + + -- Recur inside Mismatch to get the underlying reason + ConRecursInto "Mismatch" = 'Just MismatchMsg + + -- Recur inside empty statements groups to get the underlying statements block + ConRecursInto "TcRnEmptyStmtsGroup" = 'Just EmptyStatementGroupErrReason + ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Any other constructors: don't recur, instead directly + -- use the constructor name for the error code. + + ConRecursInto _ = 'Nothing + +{- ********************************************************************* +* * + Generics machinery +* * +********************************************************************* -} + +{- Note [Diagnostic codes using generics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Diagnostic codes are specified at the type-level using the injective +type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic +codes, giving quick feedback (in the form of a type error). + +Using this type family, we need to obtain corresponding value-level +functions, e.g. + + diagnosticCode :: TcRnMessage -> DiagnosticCode + diagnosticCode diag = case diag of + TcRnInaccessibleCode {} -> ghcDiagnosticCode 40564 + TcRnTypeDoesNotHaveFixedRuntimeRep {} -> ghcDiagnosticCode 18478 + TcRnCannotDeriveInstance _ _ _ _ reason -> + case reason of + DerivErrNotWellKinded {} -> ghcDiagnosticCode 62016 + DerivErrNotAClass {} -> ghcDiagnosticCode 63388 + ... + ... + +For some constructors, such as 'TcRnInaccessibleCode', we directly get a +diagnostic code, using the 'GhcDiagnosticCode' type family. For other +constructors, such as 'TcRnCannotDeriveInstance', we instead recur into an +argument (in this case 'DeriveInstanceErrReason') to obtain a diagnostic code. + +To achieve this, we use a variant of the 'typed' lens from 'generic-lens' +(we only need a getter, not a setter): + + - Using GHC.Generics, we obtain the type-level structure + of diagnostic types, as sums of products, with extra metadata. + - The 'ConRecursInto' type family declares when we should + recur into an argument of the constructor instead of using + the constructor name itself for the diagnostic code. + - To decide whether to recur, in the generic representation, + we must look at all factors of a product to see if there is + a type we should recur into. We look at the left branch + first, and decide whether to recur into it using the + HasTypeQ type family. + - The two different behaviours are controlled by two main instances (*) and (**). + - (*) recurs into a subtype, when we have a type family equation such as: + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + + In this case, for the constructor 'TcRnCannotDeriveInstance', we recur into the + type 'DeriveInstanceErrReason'. + The overlapping instance (ERR1) provides an error message in case a constructor + does not have the type specified by the 'ConRecursInto' type family. + - (**) directly uses the constructor name, by using the 'GhcDiagnosticCode' + type family. The 'KnownConstructor' context (ERR2) on the instance provides + a custom error message in case of a missing diagnostic code, which points + GHC contributors to the documentation explaining how to add diagnostic codes + for their diagnostics. +-} + +-- | Use the generic representation of a type to retrieve the +-- diagnostic code, using the 'GhcDiagnosticCode' type family. +-- +-- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes. +type GDiagnosticCode :: (Type -> Type) -> Constraint +class GDiagnosticCode f where + gdiagnosticCode :: f a -> Maybe DiagnosticCode + +type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint +class ConstructorCode con f recur where + gconstructorCode :: f a -> Maybe DiagnosticCode +instance KnownConstructor con => ConstructorCode con f 'Nothing where + gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy# + +-- If we recur into the 'UnknownDiagnostic' existential datatype, +-- unwrap the existential and obtain the error code. +instance {-# OVERLAPPING #-} + ( ConRecursInto con ~ 'Just UnknownDiagnostic + , HasType UnknownDiagnostic con f ) + => ConstructorCode con f ('Just UnknownDiagnostic) where + gconstructorCode diag = case getType @UnknownDiagnostic @con @f diag of + UnknownDiagnostic diag -> diagnosticCode diag + +-- (*) Recursive instance: Recur into the given type. +instance ( ConRecursInto con ~ 'Just ty, HasType ty con f + , Generic ty, GDiagnosticCode (Rep ty) ) + => ConstructorCode con f ('Just ty) where + gconstructorCode diag = constructorCode (getType @ty @con @f diag) + +-- (**) Constructor instance: handle constructors directly. +-- +-- Obtain the code from the 'GhcDiagnosticCode' +-- type family, applied to the name of the constructor. +instance (ConstructorCode con f recur, recur ~ ConRecursInto con) + => GDiagnosticCode (M1 i ('MetaCons con x y) f) where + gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x + +-- Handle sum types (the diagnostic types are sums of constructors). +instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where + gdiagnosticCode (L1 x) = gdiagnosticCode @f x + gdiagnosticCode (R1 y) = gdiagnosticCode @g y + +-- Discard metadata we don't need. +instance GDiagnosticCode f + => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCode (M1 x) = gdiagnosticCode @f x + +-- | Decide whether to pick the left or right branch +-- when deciding how to recurse into a product. +type family HasTypeQ (ty :: Type) f :: Maybe Type where + HasTypeQ typ (M1 _ _ (K1 _ typ)) + = 'Just typ + HasTypeQ typ (M1 _ _ x) + = HasTypeQ typ x + HasTypeQ typ (l :*: r) + = Alt (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (l :+: r) + = Both (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (K1 _ _) + = 'Nothing + HasTypeQ typ U1 + = 'Nothing + HasTypeQ typ V1 + = 'Nothing + +type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Both ('Just a) ('Just a) = 'Just a + +type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Alt ('Just a) _ = 'Just a + Alt _ b = b + +type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint +class HasType ty orig f where + getType :: f a -> ty + +instance HasType ty orig (M1 i s (K1 x ty)) where + getType (M1 (K1 x)) = x +instance HasTypeProd ty (HasTypeQ ty f) orig f g => HasType ty orig (f :*: g) where + getType = getTypeProd @ty @(HasTypeQ ty f) @orig + +-- The lr parameter tells us whether to pick the left or right +-- branch in a product, and is computed using 'HasTypeQ'. +-- +-- If it's @Just l@, then we have found the type in the left branch, +-- so use that. Otherwise, look in the right branch. +class HasTypeProd ty lr orig f g where + getTypeProd :: (f :*: g) a -> ty + +-- Pick the left branch. +instance HasType ty orig f => HasTypeProd ty ('Just l) orig f g where + getTypeProd (x :*: _) = getType @ty @orig @f x + +-- Pick the right branch. +instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where + getTypeProd (_ :*: y) = getType @ty @orig @g y + +{- ********************************************************************* +* * + Custom type errors for diagnostic codes +* * +********************************************************************* -} + +-- (ERR1) Improve error messages for recurring into an argument. +instance {-# OVERLAPPABLE #-} + TypeError + ( 'Text "The constructor '" ':<>: 'Text orig ':<>: 'Text "'" + ':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "This is likely due to an incorrect type family equation:" + ':$$: 'Text " ConRecursInto \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty ) + => HasType ty orig f where + getType = panic "getType: unreachable" + +-- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations. +type KnownConstructor :: Symbol -> Constraint +type family KnownConstructor con where + KnownConstructor con = + KnownNatOrErr + ( TypeError + ( 'Text "Missing diagnostic code for constructor " + ':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes" + ':$$: 'Text "contains instructions for adding a new diagnostic code." + ) + ) + (GhcDiagnosticCode con) + +type KnownNatOrErr :: Constraint -> Nat -> Constraint +type KnownNatOrErr err n = (Assert err n, KnownNat n) + +-- Detecting a stuck type family using a data family. +-- See https://blog.csongor.co.uk/report-stuck-families/. +type Assert :: Constraint -> k -> Constraint +type family Assert err n where + Assert _ Dummy = Dummy + Assert _ n = () +data family Dummy :: k diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString {- % @@ -71,8 +72,7 @@ -} module GHC.Types.FieldLabel - ( FieldLabelString - , FieldLabelEnv + ( FieldLabelEnv , FieldLabel(..) , fieldSelectorOccName , fieldLabelPrintableName @@ -89,16 +89,16 @@ import GHC.Data.FastString import GHC.Data.FastString.Env +import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.DeepSeq import Data.Bool import Data.Data --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel @@ -117,13 +117,22 @@ deriving (Data, Eq) instance HasOccName FieldLabel where - occName = mkVarOccFS . flLabel + occName = mkVarOccFS . field_label . flLabel instance Outputable FieldLabel where ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) <> ppr (flHasDuplicateRecordFields fl) <> ppr (flHasFieldSelector fl)) +instance Outputable FieldLabelString where + ppr (FieldLabelString l) = ppr l + +instance Uniquable FieldLabelString where + getUnique (FieldLabelString fs) = getUnique fs + +instance NFData FieldLabel where + rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. data DuplicateRecordFields = DuplicateRecordFields -- ^ Fields may be duplicated in a single module @@ -138,6 +147,8 @@ ppr DuplicateRecordFields = text "+dup" ppr NoDuplicateRecordFields = text "-dup" +instance NFData DuplicateRecordFields where + rnf x = x `seq` () -- | Flag to indicate whether the FieldSelectors extension is enabled. data FieldSelectors @@ -153,6 +164,8 @@ ppr FieldSelectors = text "+sel" ppr NoFieldSelectors = text "-sel" +instance NFData FieldSelectors where + rnf x = x `seq` () -- | We need the @Binary Name@ constraint here even though there is an instance -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the @@ -160,7 +173,7 @@ -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where put_ bh (FieldLabel aa ab ac ad) = do - put_ bh aa + put_ bh (field_label aa) put_ bh ab put_ bh ac put_ bh ad @@ -169,7 +182,7 @@ ab <- get bh ac <- get bh ad <- get bh - return (FieldLabel aa ab ac ad) + return (FieldLabel (FieldLabelString aa) ab ac ad) -- | Record selector OccNames are built from the underlying field name @@ -179,9 +192,10 @@ fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName fieldSelectorOccName lbl dc dup_fields_ok has_sel | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl + | otherwise = mkVarOccFS fl where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + fl = field_label lbl + str = concatFS [fsLit ":", fl, fsLit ":", occNameFS dc] -- | Undo the name mangling described in Note [FieldLabel] to produce a Name -- that has the user-visible OccName (but the selector's unique). This should @@ -189,7 +203,7 @@ -- need to qualify it with a module prefix. fieldLabelPrintableName :: FieldLabel -> Name fieldLabelPrintableName fl - | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl)) + | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) | otherwise = flSelector fl -- | Selector name mangling should be used if either DuplicateRecordFields or diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -153,7 +153,7 @@ See: http://www.programmersheaven.com/2/Calling-conventions -} --- any changes here should be replicated in the CallConv type in template haskell +-- any changes here should be replicated in the Callconv type in template haskell data CCallConv = CCallConv | CApiConv @@ -219,8 +219,8 @@ | otherwise = text "_unsafe" ppr_fun (StaticTarget st lbl mPkgId isFun) - = text (if isFun then "__ffi_static_ccall" - else "__ffi_static_ccall_value") + = (if isFun then text "__ffi_static_ccall" + else text "__ffi_static_ccall_value") <> gc_suf <+> (case mPkgId of Nothing -> empty diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs --- a/compiler/GHC/Types/ForeignStubs.hs +++ b/compiler/GHC/Types/ForeignStubs.hs @@ -1,5 +1,6 @@ -- | Foreign export stubs {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.ForeignStubs ( ForeignStubs (..) , CHeader(..) @@ -44,7 +45,7 @@ where body' = vcat [ declarations - , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"] + , hsep [text "void", pprCLabel platform clbl, text "(void)"] , braces body ] @@ -68,10 +69,10 @@ instance Monoid CHeader where mempty = CHeader empty - mconcat = coerce vcat + mconcat = coerce (vcat @SDoc) instance Semigroup CHeader where - (<>) = coerce ($$) + (<>) = coerce (($$) @SDoc) -- | Foreign export stubs data ForeignStubs diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -31,11 +31,13 @@ import GHC.Unit.Module (ModuleName, Module) import GHC.Hs.Extension (GhcTc) import GHC.Core.Coercion +import GHC.Core.Type (PredType) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Activation, RuleName) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Parser.Errors.Basic import {-# SOURCE #-} Language.Haskell.Syntax.Expr import GHC.Unit.Module.Imported (ImportedModsVal) @@ -63,7 +65,7 @@ -- it's totally irrelevant/redundant for IDEs and other tools. SuggestSingleExtension !SDoc !LangExt.Extension -- | Suggest to enable the input extensions. The list - -- is to be intended as /disjuctive/ i.e. the user is + -- is to be intended as /disjunctive/ i.e. the user is -- suggested to enable /any/ of the extensions listed. If -- the input 'SDoc' is not empty, it will contain some extra -- information about the why the extensions are required, but @@ -136,6 +138,14 @@ -} | SuggestExtension !LanguageExtensionHint + {-| Suggests possible corrections of a misspelled pragma. Its argument + represents all applicable suggestions. + + Example: {-# LNGUAGE BangPatterns #-} + + Test case(s): parser/should_compile/T21589 + -} + | SuggestCorrectPragmaName ![String] {-| Suggests that a monadic code block is probably missing a \"do\" keyword. Example: @@ -393,11 +403,24 @@ Test cases: ccfail004 -} | SuggestImportingDataCon - {- Found a pragma in the body of a module, suggest placing it in the header -} | SuggestPlacePragmaInHeader + {-| Suggest using pattern matching syntax for a non-bidirectional pattern synonym + + Test cases: patsyn/should_fail/record-exquant + typecheck/should_fail/T3176 + -} + | SuggestPatternMatchingSyntax + {-| Suggest tips for making a definition visible for the purpose of writing + a SPECIALISE pragma for it in a different module. + + Test cases: none + -} + | SuggestSpecialiseVisibilityHints Name + + | LoopySuperclassSolveHint PredType ClsInstOrQC -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -13,8 +13,9 @@ import GHC.Types.Hint import GHC.Hs.Expr () -- instance Outputable +import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Types.Id -import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace) +import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule) import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) import GHC.Unit.Module.Imported (ImportedModsVal(..)) @@ -40,6 +41,8 @@ in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo SuggestExtensionInOrderTo extraUserInfo ext -> (text "Use" <+> ppr ext) $$ extraUserInfo + SuggestCorrectPragmaName suggestions + -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo @@ -197,6 +200,21 @@ SuggestPlacePragmaInHeader -> text "Perhaps you meant to place it in the module header?" $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword" + SuggestPatternMatchingSyntax + -> text "Use pattern-matching syntax instead" + SuggestSpecialiseVisibilityHints name + -> text "Make sure" <+> ppr mod <+> text "is compiled with -O and that" + <+> quotes (ppr name) <+> text "has an INLINABLE pragma" + where + mod = nameModule name + LoopySuperclassSolveHint pty cls_or_qc + -> vcat [ text "Add the constraint" <+> quotes (ppr pty) <+> text "to the" <+> what <> comma + , text "even though it seems logically implied by other constraints in the context." ] + where + what :: SDoc + what = case cls_or_qc of + IsClsInst -> text "instance context" + IsQC {} -> text "context of the quantified constraint" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -86,21 +86,20 @@ idInlineActivation, setInlineActivation, idRuleMatchInfo, -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, setOneShotLambda, clearOneShotLambda, updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, -- ** Reading 'IdInfo' fields idArity, idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLFInfo_maybe, - idOneShotInfo, idStateHackOneShotInfo, + idOneShotInfo, idOccInfo, - isNeverRepPolyId, + IdUnfoldingFun, idUnfolding, realIdUnfolding, + alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun, + -- ** Writing 'IdInfo' fields setIdUnfolding, zapIdUnfolding, setCaseBndrEvald, setIdArity, @@ -129,8 +128,9 @@ import GHC.Prelude -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) +import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding + , isCompulsoryUnfolding, Unfolding( NoUnfolding ) + , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) import GHC.Types.Id.Info import GHC.Types.Basic @@ -146,7 +146,6 @@ import GHC.Core.Type import GHC.Types.RepType -import GHC.Builtin.Types.Prim import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr @@ -167,8 +166,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.GlobalVars -import GHC.Utils.Trace import GHC.Stg.InferTags.TagSig -- infixl so you can say (id `set` a `set` b) @@ -315,7 +312,7 @@ 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 @@ -383,7 +380,7 @@ -- | 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 @@ -502,16 +499,16 @@ _other -> Nothing isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False + PrimOpId {} -> True + _ -> False isDFunId id = case Var.idDetails id of DFunId {} -> True _ -> False isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing + PrimOpId op _ -> Just op + _ -> Nothing isFCallId id = case Var.idDetails id of FCallId _ -> True @@ -586,7 +583,12 @@ -- exception to this is unboxed tuples and sums datacons, which definitely have -- no binding hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps + +-- TEMPORARILY make all primops hasNoBinding, to avoid #20155 +-- The goal is to understand #20155 and revert to the commented out version + PrimOpId _ _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps +-- PrimOpId _ lev_poly -> lev_poly -- TEMPORARILY commented out + FCallId _ -> True DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc _ -> isCompulsoryUnfolding (realIdUnfolding id) @@ -695,8 +697,6 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id --- | This function counts all arguments post-unarisation, which includes --- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) @@ -747,9 +747,28 @@ -- loop breaker. See 'unfoldingInfo'. -- -- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'. -idUnfolding :: Id -> Unfolding +idUnfolding :: IdUnfoldingFun idUnfolding id = unfoldingInfo (idInfo id) +noUnfoldingFun :: IdUnfoldingFun +noUnfoldingFun _id = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) always active +alwaysActiveUnfoldingFun :: IdUnfoldingFun +alwaysActiveUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) active in according to is_active +whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun +whenActiveUnfoldingFun is_active id + | is_active (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding + realIdUnfolding :: Id -> Unfolding -- ^ Expose the unfolding if there is one, including for loop breakers realIdUnfolding id = realUnfoldingInfo (idInfo id) @@ -922,64 +941,6 @@ idOneShotInfo :: Id -> OneShotInfo idOneShotInfo id = oneShotInfo (idInfo id) --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | unsafeHasNoStateHack - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id @@ -1105,6 +1066,7 @@ old_strictness = dmdSigInfo old_info new_strictness = prependArgsDmdSig arity_increase old_strictness old_cpr = cprSigInfo old_info + new_cpr = prependArgsCprSig arity_increase old_cpr old_cbv_marks = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id) abstr_cbv_marks = mapMaybe getMark abstract_wrt @@ -1118,11 +1080,8 @@ , mightBeLiftedType (idType v) = Just MarkedCbv | otherwise = Just NotMarkedCbv - transfer new_info = new_info `setArityInfo` new_arity + transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setDmdSigInfo` new_strictness - `setCprSigInfo` old_cpr - -isNeverRepPolyId :: Id -> Bool -isNeverRepPolyId = isNeverRepPolyIdInfo . idInfo + `setOccInfo` new_occ_info + `setDmdSigInfo` new_strictness + `setCprSigInfo` new_cpr diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -83,10 +83,6 @@ -- ** Tick-box Info TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverRepPoly, setLevityInfoWithType, - isNeverRepPolyIdInfo ) where import GHC.Prelude @@ -100,13 +96,11 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.PatSyn -import GHC.Core.Type import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -126,9 +120,7 @@ `setCafInfo`, `setDmdSigInfo`, `setCprSigInfo`, - `setDemandInfo`, - `setNeverRepPoly`, - `setLevityInfoWithType` + `setDemandInfo` {- ************************************************************************ * * @@ -161,7 +153,11 @@ | ClassOpId Class -- ^ The 'Id' is a superclass selector, -- or class operation of a class - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | PrimOpId PrimOp Bool -- ^ The 'Id' is for a primitive operator + -- True <=> is representation-polymorphic, + -- and hence has no binding + -- This lev-poly flag is used only in GHC.Types.Id.hasNoBinding + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc @@ -259,7 +255,7 @@ and if no arguments are visible requires us to eta-expand it's call site. That is for a binding with three cbv arguments like `w[WorkerLikeId[!,!,!]]` we would need to eta expand undersaturated -occurences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs. +occurrences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs. In experiments it turned out that the code size increase of doing so can outweigh the performance benefits of doing so. @@ -269,7 +265,7 @@ this problem can't occur for them. For workers and specialized functions there are also always at least some applied arguments as we won't inline the wrapper/apply their rule -if there are unapplied occurances like `map f xs`. +if there are unapplied occurrences like `map f xs`. -} -- | Recursive Selector Parent @@ -310,7 +306,7 @@ pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" + pp (PrimOpId {}) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") @@ -357,33 +353,33 @@ occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program dmdSigInfo :: DmdSig, - -- ^ A strictness signature. Digests how a function uses its arguments - -- if applied to at least 'arityInfo' arguments. + -- ^ A strictness signature. Describes how a function uses its arguments + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal cprSigInfo :: CprSig, -- ^ Information on whether the function will ultimately return a -- freshly allocated constructor. demandInfo :: Demand, -- ^ ID demand information bitfield :: {-# UNPACK #-} !BitField, - -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and + -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, and -- call arity info in one 64-bit word. Packing these fields reduces size -- of `IdInfo` from 12 words to 7 words and reduces residency by almost -- 4% in some programs. See #17497 and associated MR. -- -- See documentation of the getters for what these packed fields mean. lfInfo :: !(Maybe LambdaFormInfo), - -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) } --- | Encodes arities, OneShotInfo, CafInfo and LevityInfo. +-- | Encodes arities, OneShotInfo, CafInfo. -- From least-significant to most-significant bits: -- -- - Bit 0 (1): OneShotInfo -- - Bit 1 (1): CafInfo --- - Bit 2 (1): LevityInfo +-- - Bit 2 (1): unused -- - Bits 3-32(30): Call Arity info -- - Bits 33-62(30): Arity info -- @@ -400,10 +396,6 @@ bitfieldGetCafInfo (BitField bits) = if testBit bits 1 then NoCafRefs else MayHaveCafRefs -bitfieldGetLevityInfo :: BitField -> LevityInfo -bitfieldGetLevityInfo (BitField bits) = - if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo - bitfieldGetCallArityInfo :: BitField -> ArityInfo bitfieldGetCallArityInfo (BitField bits) = fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1) @@ -424,12 +416,6 @@ MayHaveCafRefs -> BitField (clearBit bits 1) NoCafRefs -> BitField (setBit bits 1) -bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField -bitfieldSetLevityInfo info (BitField bits) = - case info of - NoLevityInfo -> BitField (clearBit bits 2) - NeverLevityPolymorphic -> BitField (setBit bits 2) - bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetCallArityInfo info bf@(BitField bits) = assert (info < 2^(30 :: Int) - 1) $ @@ -443,16 +429,12 @@ -- Getters --- | When applied, will this Id ever have a representation-polymorphic type? -levityInfo :: IdInfo -> LevityInfo -levityInfo = bitfieldGetLevityInfo . bitfield - -- | Info about a lambda-bound variable, if the 'Id' is one oneShotInfo :: IdInfo -> OneShotInfo oneShotInfo = bitfieldGetOneShotInfo . bitfield -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments --- this 'Id' has to be applied to before it does any meaningful work. +-- this 'Id' has to be applied to before it doesn any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield @@ -487,7 +469,7 @@ unfoldingInfo :: IdInfo -> Unfolding unfoldingInfo info | isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info - | otherwise = realUnfoldingInfo info + | otherwise = realUnfoldingInfo info setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf @@ -549,7 +531,6 @@ bitfieldSetArityInfo unknownArity $ bitfieldSetCallArityInfo unknownArity $ bitfieldSetOneShotInfo NoOneShotInfo $ - bitfieldSetLevityInfo NoLevityInfo $ emptyBitField, lfInfo = Nothing, tagSig = Nothing @@ -864,55 +845,3 @@ instance Outputable TickBoxOp where ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be representation-polymorphic at any amount -of saturation. This is helpful in optimizing representation polymorphism checks, -allowing us to learn that something is not representation-polymorphic without -actually figuring out its type. -See exprHasFixedRuntimeRep in GHC.Core.Utils for where this info is used. - -Historical note: this was very important when representation polymorphism -was checked in the desugarer (it was needed to prevent T5631 from blowing up). -It's less important now that the checks happen in the typechecker, but remains useful. -Refer to Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for details -about the new approach being used. --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never representation-polymorphic --- (even when applied). The Type is only there for checking that it's really --- never representation-polymorphic. -setNeverRepPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverRepPoly info ty - = assertPpr (resultHasFixedRuntimeRep ty) (ppr ty) $ - info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | resultHasFixedRuntimeRep ty - = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } - | otherwise - = info - -isNeverRepPolyIdInfo :: IdInfo -> Bool -isNeverRepPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -17,7 +17,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Types.Id.Make ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + mkDictFunId, mkDictSelId, mkDictSelRhs, mkFCallId, @@ -25,6 +25,7 @@ DataConBoxer(..), vanillaDataConBoxer, mkDataConRep, mkDataConWorkId, DataConBangOpts (..), BangOpts (..), + unboxedUnitExpr, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, @@ -32,7 +33,10 @@ voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, coerceId, - proxyHashId, noinlineId, noinlineIdName, + proxyHashId, + nospecId, nospecIdName, + noinlineId, noinlineIdName, + noinlineConstraintId, noinlineConstraintIdName, coerceName, leftSectionName, rightSectionName, ) where @@ -43,6 +47,7 @@ import GHC.Builtin.Names import GHC.Core +import GHC.Core.Opt.Arity( typeOneShot ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep @@ -51,7 +56,7 @@ import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase ) +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -69,7 +74,7 @@ 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 @@ -80,7 +85,7 @@ import GHC.Data.FastString import GHC.Data.List.SetOps - +import Data.List ( zipWith4 ) {- ************************************************************************ @@ -159,7 +164,7 @@ ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId] +magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -307,14 +312,15 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~ @@ -356,7 +362,7 @@ We'd like 'map Age' to match the LHS. For this to happen, Age must be unfolded, otherwise we'll be stuck. This is tested in T16208. -It also allows for the posssibility of representation-polymorphic newtypes +It also allows for the possibility of representation-polymorphic newtypes with wrappers (with -XUnliftedNewtypes): newtype N (a :: TYPE r) = MkN a @@ -471,20 +477,19 @@ 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] base_info = noCafIdInfo - `setArityInfo` 1 - `setDmdSigInfo` strict_sig - `setCprSigInfo` topCprSig - `setLevityInfoWithType` sel_ty + `setArityInfo` 1 + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - defaultSimpleOpts + `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts + StableSystemSrc 1 (mkDictSelRhs clas val_index) -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance -- for why alwaysInlinePragma @@ -492,8 +497,8 @@ | otherwise = base_info `setRuleInfo` mkRuleInfo [rule] `setInlinePragInfo` neverInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - defaultSimpleOpts + `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts + StableSystemSrc 1 (mkDictSelRhs clas val_index) -- Add a magic BuiltinRule, but no unfolding -- so that the rule is always available to fire. @@ -585,26 +590,25 @@ `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 - `setLevityInfoWithType` wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverRepPoly + -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon 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 `setInlinePragInfo` dataConWrapperInlinePragma `setUnfoldingInfo` newtype_unf - `setLevityInfoWithType` wkr_ty 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 defaultSimpleOpts $ + mkCompulsoryUnfolding $ mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) @@ -621,7 +625,7 @@ type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) +data Boxer = UnitBox | Boxer (Subst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars -- | Data Constructor Boxer @@ -684,8 +688,10 @@ | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + ; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers) initial_wrap_app + -- Drop the stupid theta arguments, as per + -- Note [Instantiating stupid theta] in GHC.Core.DataCon. ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info wrap_info = noCafIdInfo @@ -698,8 +704,9 @@ -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane - `setLevityInfoWithType` wrap_ty + -- The signature is purely for passes like the Simplifier, not for + -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers]. wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv wrap_arg_dmds = @@ -722,9 +729,9 @@ -- See Note [Inline partially-applied constructor wrappers] -- Passing Nothing here allows the wrapper to inline when -- unsaturated. - wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOpts wrap_rhs + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs -- See Note [Compulsory newtype unfolding] - | otherwise = mkInlineUnfolding defaultSimpleOpts wrap_rhs + | otherwise = mkDataConUnfolding wrap_rhs wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ wrapFamInstBody tycon res_ty_args $ @@ -740,9 +747,10 @@ 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 @@ -751,7 +759,7 @@ ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con - wrap_arg_tys = (map unrestricted theta) ++ orig_arg_tys + wrap_arg_tys = (map unrestricted $ stupid_theta ++ theta) ++ orig_arg_tys wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the @@ -776,20 +784,44 @@ (unboxers, boxers) = unzip wrappers (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + -- This is True if the data constructor or class dictionary constructor + -- needs a wrapper. This wrapper is injected into the program later in the + -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, + -- along with the accompanying implementation in getTyConImplicitBinds. wrapper_reqd = (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) + -- of some newtypes written with GADT syntax. + -- See dataConUserTyVarsNeedWrapper below. + && (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, but there + -- is one exception that we must check below. + && not (isTypeDataTyCon tycon)) + -- An exception to this rule is `type data` declarations. + -- Their data constructors only live at the type level and + -- therefore do not need wrappers. + -- See Note [Type data declarations] in GHC.Rename.Module. + -- + -- Note that the other checks in this definition will + -- return False for `type data` declarations, as: + -- + -- - They cannot be newtypes + -- - They cannot have strict fields + -- - They cannot be data family instances + -- - They cannot have datatype contexts + || not (null stupid_theta) + -- If the data constructor has a datatype context, + -- we need a wrapper in order to drop the stupid arguments. + -- See Note [Instantiating stupid theta] in GHC.Core.DataCon. initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args @@ -976,8 +1008,7 @@ -> Scaled Type -- ^ the type of the 'Var' -> UniqSM Var newLocal name_stem (Scaled w ty) = - do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar name_stem uniq w ty) } + mkSysLocalOrCoVarM name_stem w ty -- We should not have "OrCoVar" here, this is a bug (#17545) @@ -1012,27 +1043,22 @@ = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] - | not (bang_opt_unbox_disable bang_opts) -- Don't unpack if disabled - , let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) + | let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) -- Unwrap type families and newtypes arg_ty' = case mb_co of { Just redn -> scaledSet arg_ty (reductionReducedType redn) ; Nothing -> arg_ty } - , isUnpackableType bang_opts fam_envs (scaledThing arg_ty') - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - bang_opt_unbox_strict bang_opts - || (bang_opt_unbox_small bang_opts - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just redn -> HsUnpack (Just $ reductionCoercion redn) + , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty') + , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty' + = if bang_opt_unbox_disable bang_opts + then HsStrict True -- Not unpacking because of -O0 + -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon + else case mb_co of + Nothing -> HsUnpack Nothing + Just redn -> HsUnpack (Just $ reductionCoercion redn) | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - + = HsStrict False -- | Wrappers/Workers and representation following Unpack/Strictness -- decisions @@ -1045,12 +1071,11 @@ dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) -dataConArgRep arg_ty HsStrict +dataConArgRep arg_ty (HsStrict _) = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) + = dataConArgUnpack arg_ty dataConArgRep (Scaled w _) (HsUnpack (Just co)) | let co_rep_ty = coercionRKind co @@ -1087,50 +1112,231 @@ unitBoxer = UnitBox ------------------------- + +{- Note [UNPACK for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a data type D, for example: + data D = D1 [Int] [Bool] + | D2 + +and another data type which unpacks a field of type D: + data U a = MkU {-# UNPACK #-} !D + {-# UNPACK #-} !(a,a) + {-# UNPACK #-} !D + +Then the wrapper and worker for MkU have these types + + -- Wrapper + $WMkU :: D -> (a,a) -> D -> U a + + -- Worker + MkU :: (# (# [Int],[Bool] #) | (# #) #) + -> a + -> a + -> (# (# [Int],[Bool] #) | (# #) #) + -> U a + +For each unpacked /sum/-type argument, the worker gets one argument. +But for each unpacked /product/-type argument, the worker gets N +arguments (here two). + +Why treat them differently? See Note [Why sums and products are treated differently]. + +The wrapper $WMkU looks like this: + + $WMkU :: D -> (a,a) -> D -> U a + $WMkU x1 y x2 + = case (case x1 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x1_ubx -> + case y of { (y1, y2) -> + case (case x2 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x2_ubx -> + MkU x1_ubx y1 y2 x2_ubx + +Notice the nested case needed for sums. + +This different treatment for sums and product is implemented in +dataConArgUnpackSum and dataConArgUnpackProduct respectively. + +Note [Why sums and products are treated differently] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we handle sums like products, with each wrapper argument +occupying multiple argument slots in the worker? No: for a sum +type the number of argument slots varies, and that's exactly what +unboxed sums are designed for. + +Can we handle products like sums, with each wrapper argument occupying +exactly one argument slot (and unboxed tuple) in the worker? Yes, +we could. For example + data P = MkP {-# UNPACK #-} !Q + data Q = MkQ {-# NOUNPACK #-} !Int + {-# NOUNPACK #-} Int + +Currently could unpack P thus, taking two slots in the worker + $WMkP :: Q -> P + $WMkP x = case x of { MkQ a b -> MkP a b } + MkP :: Int -> Int -> P -- Worker + +We could instead do this (uniformly with sums) + + $WMkP1 :: Q -> P + $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x + MkP1 ubx_x + MkP1 :: (# Int, Int #) -> P -- Worker + +The representation of MkP and MkP1 would be identical (a constructor +with two fields). + +BUT, with MkP (as with every data constructor) we record its argument +strictness as a bit-vector, actually [StrictnessMark] + MkP strictness: SL +This information is used in Core to record which fields are sure to +be evaluated. (Look for calls to dataConRepStrictness.) E.g. in Core + case v of MkP x y -> ........ + +Alas, with MkP1 this information is hidden by the unboxed pair, +In Core there will be an auxiliary case expression to take apart the pair: + case v of MkP1 xy -> case xy of (# x,y #) -> ... +And now we have no easy way to know that x is evaluated in the "...". + +Fixing this might be possible, but it'd be tricky. So we avoid the +problem entirely by treating sums and products differently here. +-} + dataConArgUnpack :: Scaled Type -> ( [(Scaled Type, StrictnessMark)] -- Rep types , (Unboxer, Boxer) ) - -dataConArgUnpack (Scaled arg_mult arg_ty) +dataConArgUnpack scaledTy@(Scaled _ arg_ty) | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args - = assert (null (dataConExTyCoVars con)) - -- Note [Unpacking GADTs and existentials] - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys - ; let r_mult = idMult arg_id - ; let rep_ids' = map (scaleIdBy r_mult) rep_ids - ; let unbox_fn body - = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids' body - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) + = assert (not (isNewTyCon tc)) $ + case tyConDataCons tc of + [con] -> dataConArgUnpackProduct scaledTy tc_args con + cons -> dataConArgUnpackSum scaledTy tc_args cons | otherwise = pprPanic "dataConArgUnpack" (ppr arg_ty) -- An interface file specified Unpacked, but we couldn't unpack it -isUnpackableType :: BangOpts -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type +dataConArgUnpackProduct + :: Scaled Type + -> [Type] + -> DataCon + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackProduct (Scaled arg_mult _) tc_args con = + assert (null (dataConExTyCoVars con)) $ + -- Note [Unpacking GADTs and existentials] + let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args + in ( rep_tys `zip` dataConRepStrictness con + , ( \ arg_id -> + do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys + ; let r_mult = idMult arg_id + ; let rep_ids' = map (scaleIdBy r_mult) rep_ids + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids' body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + +dataConArgUnpackSum + :: Scaled Type + -> [Type] + -> [DataCon] + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackSum (Scaled arg_mult arg_ty) tc_args cons = + ( [ (sum_ty, MarkedStrict) ] -- The idea: Unpacked variant will + -- be one field only, and the type of the + -- field will be an unboxed sum. + , ( unboxer, boxer ) ) + where + !ubx_sum_arity = length cons + src_tys = map (\con -> map scaledThing $ dataConInstArgTys con tc_args) cons + sum_alt_tys = map mkUbxSumAltTy src_tys + sum_ty_unscaled = mkSumTy sum_alt_tys + sum_ty = Scaled arg_mult sum_ty_unscaled + newLocal' fs = newLocal fs . Scaled arg_mult + + -- See Note [UNPACK for sum types] + unboxer :: Unboxer + unboxer arg_id = do + con_arg_binders <- mapM (mapM (newLocal' (fsLit "unbx"))) src_tys + ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty + + let + mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt + mk_ubx_sum_alt alt con [bndr] = Alt (DataAlt con) [bndr] + (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys (Var bndr)) + + mk_ubx_sum_alt alt con bndrs = + let tuple = mkCoreUnboxedTuple (map Var bndrs) + in Alt (DataAlt con) bndrs (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys tuple ) + + ubx_sum :: CoreExpr + ubx_sum = + let alts = zipWith3 mk_ubx_sum_alt [ 1 .. ] cons con_arg_binders + in Case (Var arg_id) arg_id (coreAltsType alts) alts + + unbox_fn :: CoreExpr -> CoreExpr + unbox_fn body = + mkSingleAltCase ubx_sum ubx_sum_bndr DEFAULT [] body + + return ([ubx_sum_bndr], unbox_fn) + + boxer :: Boxer + boxer = Boxer $ \ subst -> do + unboxed_field_id <- newLocal' (fsLit "bx") (TcType.substTy subst sum_ty_unscaled) + tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys + + let tc_args' = substTys subst tc_args + arg_ty' = substTy subst arg_ty + + con_arg_binders <- + mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys + + let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt + mk_sum_alt alt con _ [datacon_bndr] = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [datacon_bndr] + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` [datacon_bndr] )) + + mk_sum_alt alt con tuple_bndr datacon_bndrs = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [tuple_bndr] ( + Case (Var tuple_bndr) tuple_bndr arg_ty' + [ Alt (DataAlt (tupleDataCon Unboxed (length datacon_bndrs))) datacon_bndrs + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` datacon_bndrs ) ] )) + + return ( [unboxed_field_id], + Case (Var unboxed_field_id) unboxed_field_id arg_ty' + (zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) ) + +-- | Every alternative of an unboxed sum has exactly one field, and we use +-- unboxed tuples when we need more than one field. This generates an unboxed +-- tuple when necessary, to be used in unboxed sum alts. +mkUbxSumAltTy :: [Type] -> Type +mkUbxSumAltTy [ty] = ty +mkUbxSumAltTy tys = mkTupleTy Unboxed tys + +shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool +-- True if we ought to unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves! -isUnpackableType bang_opts fam_envs ty - | Just data_con <- unpackable_type ty - = ok_con_args emptyNameSet data_con +shouldUnpackTy bang_opts prag fam_envs ty + | Just data_cons <- unpackable_type_datacons (scaledThing ty) + = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons | otherwise = False where + ok_con_args :: NameSet -> DataCon -> Bool ok_con_args dcs con | dc_name `elemNameSet` dcs = False @@ -1143,17 +1349,20 @@ dc_name = getName con dcs' = dcs `extendNameSet` dc_name + ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool ok_arg dcs (Scaled _ ty, bang) = not (attempt_unpack bang) || ok_ty dcs norm_ty where norm_ty = topNormaliseType fam_envs ty + ok_ty :: NameSet -> Type -> Bool ok_ty dcs ty - | Just data_con <- unpackable_type ty - = ok_con_args dcs data_con + | Just data_cons <- unpackable_type_datacons ty + = all (ok_con_args dcs) data_cons | otherwise = True -- NB True here, in contrast to False at top level + attempt_unpack :: HsSrcBang -> Bool attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) = bang_opt_strict_data bang_opts attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) @@ -1164,17 +1373,41 @@ = bang_opt_strict_data bang_opts -- Be conservative attempt_unpack _ = False - unpackable_type :: Type -> Maybe DataCon - -- Works just on a single level - unpackable_type ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars data_con) - -- See Note [Unpacking GADTs and existentials] - = Just data_con - | otherwise - = Nothing + -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not. + should_unpack data_cons = + case prag of + SrcNoUnpack -> False -- {-# NOUNPACK #-} + SrcUnpack -> True -- {-# UNPACK #-} + NoSrcUnpack -- No explicit unpack pragma, so use heuristics + | (_:_:_) <- data_cons + -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK. + | otherwise + -> bang_opt_unbox_strict bang_opts + || (bang_opt_unbox_small bang_opts + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + where (rep_tys, _) = dataConArgUnpack ty + +-- Given a type already assumed to have been normalized by topNormaliseType, +-- unpackable_type_datacons ty = Just datacons +-- iff ty is of the form +-- T ty1 .. tyn +-- and T is an algebraic data type (not newtype), in which no data +-- constructors have existentials, and datacons is the list of data +-- constructors of T. +unpackable_type_datacons :: Type -> Maybe [DataCon] +unpackable_type_datacons ty + | Just (tc, _) <- splitTyConApp_maybe ty + , not (isNewTyCon tc) + -- Even though `ty` has been normalised, it could still + -- be a /recursive/ newtype, so we must check for that + , Just cons <- tyConDataCons_maybe tc + , not (null cons) + , all (null . dataConExTyCoVars) cons + = Just cons -- See Note [Unpacking GADTs and existentials] + | otherwise + = Nothing + {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1317,17 +1550,16 @@ -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! - name = mkFCallName uniq occ_str + name = mkFCallName uniq (mkFastString occ_str) info = noCafIdInfo - `setArityInfo` arity - `setDmdSigInfo` strict_sig - `setCprSigInfo` topCprSig - `setLevityInfoWithType` ty + `setArityInfo` arity + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedDmdSig (replicate arity topDmd) topDiv + 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 -- necessarily force them. See #11076. @@ -1362,11 +1594,7 @@ 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) {- ************************************************************************ @@ -1402,23 +1630,22 @@ rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, noinlineIdName :: 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 ------------------------------------------------ proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverRepPoly` ty) + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] where -- proxy# :: forall {k} (a:k). Proxy# k a -- -- The visibility of the `k` binder is Inferred to match the type of the -- Proxy data constructor (#16293). - [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + [kv,tv] = mkTemplateKiTyVar liftedTypeKind (\x -> [x]) kv_ty = mkTyVarTy kv tv_ty = mkTyVarTy tv ty = mkInfForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty @@ -1431,15 +1658,14 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit) - `setNeverRepPoly` addrPrimTy + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity inline_prag @@ -1466,20 +1692,42 @@ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where - info = noCafIdInfo `setNeverRepPoly` ty + 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 `setNeverRepPoly` ty + info = noCafIdInfo + 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 + info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function] oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ @@ -1497,11 +1745,11 @@ {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The functions leftSectionId, rightSectionId are -wired in here ONLY because they are use in a representation-polymorphic way +wired in here ONLY because they are used in a representation-polymorphic way by the rebindable syntax mechanism. See GHC.Rename.Expr Note [Handling overloaded and rebindable constructs]. -Alas, we can't currenly give Haskell definitions for +Alas, we can't currently give Haskell definitions for representation-polymorphic functions. They have Compulsory unfoldings, so that the representation polymorphism @@ -1520,7 +1768,7 @@ leftSectionId = pcMiscPrelId leftSectionName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ @@ -1545,7 +1793,7 @@ rightSectionId = pcMiscPrelId rightSectionName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar , multiplicityTyVar1, multiplicityTyVar2 ] $ @@ -1554,8 +1802,8 @@ 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 @@ -1571,14 +1819,14 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` 2 eqRTy = mkTyConApp coercibleTyCon [ tYPE_r, a, b ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ] ty = mkInvisForAllTys [ Bndr rv InferredSpec , Bndr av SpecifiedSpec , Bndr bv SpecifiedSpec ] $ - mkInvisFunTyMany eqRTy $ + mkInvisFunTy eqRTy $ mkVisFunTyMany a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy @@ -1715,21 +1963,45 @@ 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. + This is only needed for noinlineId, not noInlineConstraintId (wrinkle + (W1) below), because the latter never shows up in user code. -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. +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] +~~~~~~~~~~~~~~~~~~~~~ +The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass +specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e. +Note that this happens *after* unfoldings are exposed in the interface file. +This is crucial: otherwise, we could import an unfolding in which +'nospec' has been inlined (= erased), and we would lose the benefit. + +'nospec' is used in the implementation of 'withDict': we insert 'nospec' +so that the typeclass specialiser doesn't assume any two evidence terms +of the same type are equal. See Note [withDict] in GHC.Tc.Instance.Class, +and see test case T21575b for an example. + Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 @@ -1782,10 +2054,11 @@ -} realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy +realWorldPrimId = pcMiscPrelId realWorldName id_ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverRepPoly` realWorldStatePrimTy) + `setOneShotInfo` typeOneShot id_ty) + where + id_ty = realWorldStatePrimTy voidPrimId :: Id -- Global constant :: Void# -- The type Void# is now the same as (# #) (ticket #18441), @@ -1794,13 +2067,13 @@ -- We cannot define it in normal Haskell, since it's -- a top-level unlifted value. voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy - (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs - `setNeverRepPoly` unboxedUnitTy) - where rhs = Var (dataConWorkId unboxedUnitDataCon) + (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding unboxedUnitExpr) +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 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -67,8 +67,9 @@ 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.Word import Data.Char import Data.Data ( Data ) -import GHC.Exts +import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat ) {- @@ -132,15 +133,14 @@ -- 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 @@ = 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 @@ return (LitNumber nt i) _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) + instance Outputable Literal where ppr = pprLiteral id @@ -579,7 +580,7 @@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString [] = LitString mempty -mkLitString s = LitString (utf8EncodeString s) +mkLitString s = LitString (utf8EncodeByteString s) mkLitBigNat :: Integer -> Literal mkLitBigNat x = assertPpr (x >= 0) (integer x) @@ -851,10 +852,10 @@ 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 (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 @@ -904,9 +906,13 @@ add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (LitRubbish rep) - = text "RUBBISH" <> parens (ppr rep) + Just x -> doubleQuotes (ftext l <> text ('@':show x)) +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] @@ -965,7 +971,7 @@ an IR feature. 2. Core: 'LitRubbish' carries a `Type` of kind RuntimeRep, - describing the runtime representaion of the literal (is it a + describing the runtime representation of the literal (is it a pointer, an unboxed Double#, or whatever). We have it that `RUBBISH[rr]` has type `forall (a :: TYPE rr). a`. @@ -1005,16 +1011,16 @@ 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. Wrinkles a) Why do we put the `Type` (of kind RuntimeRep) inside the literal? Could - we not instead /apply/ the literal to that RuntimeRep? Alas no, becuase + we not instead /apply/ the literal to that RuntimeRep? Alas no, because then LitRubbish :: forall (rr::RuntimeRep) (a::TYPE rr). a - and that's am ill-formed type because its kind is `TYPE rr`, which escapes + and that's an ill-formed type because its kind is `TYPE rr`, which escapes the binding site of `rr`. Annoying. b) A rubbish literal is not bottom, and replies True to exprOkForSpeculation. @@ -1044,9 +1050,9 @@ undefined behavior, of course, but let us list a few examples for failure modes: a) For an value of unboxed numeric type like `Int#`, we just use a silly - value like 42#. The error might propoagate indefinitely, hence we better + value like 42#. The error might propagate indefinitely, hence we better pick a rather unique literal. Same for Word, Floats, Char and VecRep. - b) For AddrRep (like String lits), we mit a null pointer, resulting in a + b) For AddrRep (like String lits), we emit a null pointer, resulting in a definitive segfault when accessed. c) For boxed values, unlifted or not, we use a pointer to a fixed closure, like `()`, so that the GC has a pointer to follow. diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -54,7 +54,9 @@ setNameLoc, tidyNameOcc, localiseName, + namePun_maybe, + pprName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, pprFullName, pprTickyName, @@ -83,6 +85,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) +import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon ) import GHC.Platform import GHC.Types.Name.Occurrence @@ -99,6 +102,7 @@ import Control.DeepSeq import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -332,6 +336,12 @@ is_interactive_or_from :: Module -> Module -> Bool is_interactive_or_from from mod = from == mod || isInteractiveModule mod +-- Return the pun for a name if available. +-- Used for pretty-printing under ListTuplePuns. +namePun_maybe :: Name -> Maybe FastString +namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]") +namePun_maybe _ = Nothing + nameIsLocalOrFrom :: Module -> Name -> Bool -- ^ Returns True if the name is -- (a) Internal @@ -484,8 +494,8 @@ mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) -- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan +mkFCallName :: Unique -> FastString -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOccFS str) noSrcSpan -- The encoded string completely describes the ccall -- When we renumber/rename things, we need to be @@ -527,7 +537,7 @@ stableNameCmp :: Name -> Name -> Ordering stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + = sort_cmp s1 s2 S.<> compare occ1 occ2 -- The ordinary compare on OccNames is lexicographic where -- Later constructors are bigger @@ -615,15 +625,25 @@ pprInfixOcc = pprInfixName pprPrefixOcc = pprPrefixName -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \sty -> - getPprDebug $ \debug -> +pprName :: forall doc. IsLine doc => Name -> doc +pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = docWithContext $ \ctx -> + let sty = sdocStyle ctx + debug = sdocPprDebug ctx + listTuplePuns = sdocListTuplePuns ctx + in handlePuns listTuplePuns (namePun_maybe name) $ case sort of WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin External mod -> pprExternal debug sty uniq mod occ False UserSyntax System -> pprSystem debug sty uniq occ Internal -> pprInternal debug sty uniq occ + where + -- Print GHC.Types.List as [], etc. + handlePuns :: Bool -> Maybe FastString -> doc -> doc + handlePuns True (Just pun) _ = ftext pun + handlePuns _ _ r = r +{-# SPECIALISE pprName :: Name -> SDoc #-} +{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print fully qualified name (with unit-id, module and unique) pprFullName :: Module -> Name -> SDoc @@ -654,9 +674,9 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc pprExternal debug sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? @@ -669,13 +689,13 @@ if isHoleModule mod then case qualName sty mod occ of NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ) else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = ppUnlessOption sdocSuppressModulePrefixes - (ppr mod <> dot) + (pprModule mod <> dot) -pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprInternal debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), @@ -686,7 +706,7 @@ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprSystem debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -697,38 +717,38 @@ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in GHC.Types.Name.Ppr pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either + NameQual modname -> pprModuleName modname <> dot -- Name is in scope + NameNotInScope1 -> pprModule mod <> dot -- Not in scope + NameNotInScope2 -> pprUnit (moduleUnit mod) <> colon -- Module not in + <> pprModuleName (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified -pprUnique :: Unique -> SDoc +pprUnique :: IsLine doc => Unique -> doc -- Print a unique unless we are suppressing them pprUnique uniq = ppUnlessOption sdocSuppressUniques $ pprUniqueAlways uniq -ppr_underscore_unique :: Unique -> SDoc +ppr_underscore_unique :: IsLine doc => Unique -> doc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq = ppUnlessOption sdocSuppressUniques $ char '_' <> pprUniqueAlways uniq -ppr_occ_name :: OccName -> SDoc +ppr_occ_name :: IsLine doc => OccName -> doc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name :: IsLine doc => OccName -> doc ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) -- Prints (if mod information is available) "Defined at " or diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot --- a/compiler/GHC/Types/Name.hs-boot +++ b/compiler/GHC/Types/Name.hs-boot @@ -8,6 +8,7 @@ import GHC.Types.Unique import GHC.Utils.Outputable import Data.Data (Data) +import Control.DeepSeq (NFData) data Name @@ -15,6 +16,7 @@ instance Data Name instance Uniquable Name instance Outputable Name +instance NFData Name class NamedThing a where getOccName :: a -> OccName diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs --- a/compiler/GHC/Types/Name/Cache.hs +++ b/compiler/GHC/Types/Name/Cache.hs @@ -102,7 +102,7 @@ lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE_PRIM , Just name <- isBuiltInOcc_maybe occ = -- See Note [Known-key names], 3(c) in GHC.Builtin.Names -- Special case for tuples; there are too many diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs --- a/compiler/GHC/Types/Name/Env.hs +++ b/compiler/GHC/Types/Name/Env.hs @@ -19,7 +19,7 @@ unitNameEnv, nonDetNameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, + filterNameEnv, mapMaybeNameEnv, anyNameEnv, plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, @@ -121,6 +121,7 @@ lookupNameEnv :: NameEnv a -> Name -> Maybe a lookupNameEnv_NF :: NameEnv a -> Name -> a filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +mapMaybeNameEnv :: (a -> Maybe b) -> NameEnv a -> NameEnv b anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 disjointNameEnv :: NameEnv a -> NameEnv a -> Bool @@ -149,6 +150,7 @@ delFromNameEnv x y = delFromUFM x y delListFromNameEnv x y = delListFromUFM x y filterNameEnv x y = filterUFM x y +mapMaybeNameEnv x y = mapMaybeUFM x y anyNameEnv f x = foldUFM ((||) . f) False x disjointNameEnv x y = disjointUFM x y seqEltsNameEnv seqElt x = seqEltsUFM seqElt x diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -6,7 +6,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -- | -- #name_types# @@ -115,6 +114,7 @@ import Control.DeepSeq import Data.Char import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -200,7 +200,7 @@ pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief :: IsLine doc => NameSpace -> doc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = text "tv" @@ -246,8 +246,7 @@ instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `lexicalCompareFS` s2) `thenCmp` (sp1 `compare` sp2) + compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2 instance Data OccName where -- don't traverse? @@ -277,29 +276,14 @@ pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) -pprOccName :: OccName -> SDoc +pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty + = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) then ztext (zEncodeFS occ) - else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) - where - pp_occ = sdocOption sdocSuppressUniques $ \case - True -> text (strip_th_unique (unpackFS occ)) - False -> ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] + else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) {- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in "GHC.ThToHs" - ************************************************************************ * * \subsection{Construction} @@ -535,7 +519,9 @@ startsWithUnderscore :: OccName -> Bool -- ^ Haskell 98 encourages compilers to suppress warnings about unused -- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' +startsWithUnderscore occ = case unpackFS (occNameFS occ) of + '_':_ -> True + _ -> False {- ************************************************************************ @@ -660,8 +646,8 @@ mkGen1R = mk_simple_deriv tcName "Rep1_" -- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] +mkRecFldSelOcc :: FastString -> OccName +mkRecFldSelOcc s = mk_deriv varName "$sel" [s] mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] @@ -807,7 +793,6 @@ Note [Tidying multiple names at once] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider > :t (id,id,id) @@ -875,13 +860,13 @@ base1 = mkFastString (base ++ "1") find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) + = case elemUFM new_fs env of + True -> find (k+1 :: Int) (n+k) -- By using n+k, the n argument to find goes -- 1, add 1, add 2, add 3, etc which -- moves at quadratic speed through a dense patch - Nothing -> (new_env, OccName occ_sp new_fs) + False -> (new_env, OccName occ_sp new_fs) where new_fs = mkFastString (base ++ show n) new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) diff --git a/compiler/GHC/Types/Name/Occurrence.hs-boot b/compiler/GHC/Types/Name/Occurrence.hs-boot --- a/compiler/GHC/Types/Name/Occurrence.hs-boot +++ b/compiler/GHC/Types/Name/Occurrence.hs-boot @@ -1,13 +1,12 @@ module GHC.Types.Name.Occurrence where -import GHC.Prelude (String) -import GHC.Data.FastString +import GHC.Data.FastString ( FastString ) data OccName class HasOccName name where occName :: name -> OccName -occNameString :: OccName -> String -mkRecFldSelOcc :: String -> OccName +occNameFS :: OccName -> FastString +mkRecFldSelOcc :: FastString -> OccName mkVarOccFS :: FastString -> OccName diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -1,7 +1,7 @@ module GHC.Types.Name.Ppr - ( mkPrintUnqualified + ( mkNamePprCtx , mkQualModule , mkQualPackage , pkgQual @@ -9,6 +9,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env @@ -16,12 +17,12 @@ 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 {- @@ -52,7 +53,7 @@ things around, P1:M.T and P2:M.T? Then we don't want to print both of them as M.T! However only one of the modules P1:M and P2:M can be exposed (say P2), so we use M.T for that, and P1:M.T for the other one. -This is handled by the qual_mod component of PrintUnqualified, inside +This is handled by the qual_mod component of NamePprCtx, inside the (ppr mod) of case (3), in Name.pprModulePrefix Note [Printing unit ids] @@ -66,14 +67,19 @@ -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified unit_env env - = QueryQualify qual_name +mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx +mkNamePprCtx ptc unit_env env + = QueryQualify + (mkQualName env) (mkQualModule unit_state home_unit) (mkQualPackage unit_state) + (mkPromTick ptc env) where unit_state = ue_units unit_env home_unit = ue_homeUnit unit_env + +mkQualName :: GlobalRdrEnv -> QueryQualifyName +mkQualName env = qual_name where qual_name mod occ | [gre] <- unqual_gres , right_name gre @@ -112,7 +118,7 @@ , coercibleTyConName , eqTyConName , tYPETyConName - , funTyConName + , fUNTyConName, unrestrictedFunTyConName , oneDataConName , manyDataConName ] @@ -125,8 +131,38 @@ -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). +mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick +mkPromTick ptc env + | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick + | otherwise = print_prom_tick + where + print_prom_tick (PromotedItemListSyntax (IsEmptyOrSingleton eos)) = + -- Ticked: '[], '[x] + -- Unticked: [x,y], [x,y,z], and so on + ptcListTuplePuns ptc && eos + print_prom_tick PromotedItemTupleSyntax = + ptcListTuplePuns ptc + print_prom_tick (PromotedItemDataCon occ) + | isPunnedDataConName occ -- '[], '(,), ''(,,) + = ptcListTuplePuns ptc + + | Just occ' <- promoteOccName occ + , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env + = -- Could not find a corresponding type name in the environment, + -- so the data name is unambiguous. Promotion tick not needed. + False + | otherwise = True + +isPunnedDataConName :: OccName -> Bool +isPunnedDataConName occ = + isDataOcc occ && case unpackFS (occNameFS occ) of + '[':_ -> True + '(':_ -> True + _ -> False + {- 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 @@ -199,5 +235,5 @@ -- | A function which only qualifies package names if necessary; but -- qualifies all other identifiers. -pkgQual :: UnitState -> PrintUnqualified +pkgQual :: UnitState -> NamePprCtx pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs } diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -93,8 +93,11 @@ import GHC.Utils.Panic import GHC.Types.Name.Env +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Data.Data import Data.List( sortBy ) +import qualified Data.Semigroup as S import GHC.Data.Bag {- @@ -339,10 +342,10 @@ compare (Qual _ _) (Exact _) = GT compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Qual _ _) (Orig _ _) = LT - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Orig _ _) _ = GT {- @@ -709,7 +712,7 @@ greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified) --- Prerecondition: the greMangledName is always External +-- Precondition: the greMangledName is always External greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | lcl, Just mod <- greDefinitionModule gre = moduleName mod | Just is <- headMaybe iss = is_as (is_decl is) @@ -822,12 +825,12 @@ remove_locals gres | locals_only = filter isLocalGRE gres | otherwise = gres pp [] = empty - pp gres = hang (ppr occ + pp gres@(gre:_) = hang (ppr occ <+> parens (text "unique" <+> ppr (getUnique occ)) <> colon) 2 (vcat (map ppr gres)) where - occ = nameOccName (greMangledName (head gres)) + occ = nameOccName (greMangledName gre) lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of @@ -867,7 +870,7 @@ -- selector name and field label may be different: the GlobalRdrEnv is keyed on -- the label. See Note [GreNames] for why this happens. lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) + = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' @@ -1243,8 +1246,7 @@ -- earlier declaration wins over later best (ImpSpec { is_item = item1, is_decl = d1 }) (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) `thenCmp` - (best_item item1 item2) `thenCmp` + = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<> SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) best_item :: ImpItemSpec -> ImpItemSpec -> Ordering diff --git a/compiler/GHC/Types/ProfAuto.hs b/compiler/GHC/Types/ProfAuto.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/ProfAuto.hs @@ -0,0 +1,15 @@ +module GHC.Types.ProfAuto + ( ProfAuto (..) + ) +where + +import GHC.Prelude + +-- | What kind of {-# SCC #-} to add automatically +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -13,7 +13,7 @@ -- * Type representation for the code generator typePrimRep, typePrimRep1, runtimeRepPrimRep, typePrimRepArgs, - PrimRep(..), primRepToType, primRepToRuntimeRep, + PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, tyConPrimRep, tyConPrimRep1, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, @@ -31,7 +31,6 @@ 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,8 +55,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain +import Data.List.NonEmpty (NonEmpty (..)) import Data.List (sort) import qualified Data.IntSet as IS @@ -205,14 +204,14 @@ -- -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head -- of the list we have the slot for the tag. -ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy ubxSumRepType constrs0 -- These first two cases never classify an actual unboxed sum, which always -- has at least two disjuncts. But it could happen if a user writes, e.g., -- forall (a :: TYPE (SumRep [IntRep])). ... -- which could never be instantiated. We still don't want to panic. | constrs0 `lengthLessThan` 2 - = [WordSlot] + = WordSlot :| [] | otherwise = let @@ -240,7 +239,7 @@ rep :: [PrimRep] -> SortedSlotTys rep ty = sort (map primRepSlot ty) - sumRep = WordSlot : combine_alts (map rep constrs0) + sumRep = WordSlot :| combine_alts (map rep constrs0) -- WordSlot: for the tag of the sum in sumRep @@ -306,11 +305,10 @@ ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e typeSlotTy :: UnaryType -> Maybe SlotTy -typeSlotTy ty - | isZeroBitTy ty - = Nothing - | otherwise - = Just (primRepSlot (typePrimRep1 ty)) +typeSlotTy ty = case typePrimRep ty of + [] -> Nothing + [rep] -> Just (primRepSlot rep) + reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps) primRepSlot :: PrimRep -> SlotTy primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") @@ -528,7 +526,7 @@ list as the one argument to the extracted function. The extracted function is defined as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep -to process the LiftedRep and WordRep, concatentating the results. +to process the LiftedRep and WordRep, concatenating the results. -} @@ -584,40 +582,34 @@ -- See also Note [Getting from RuntimeRep to PrimRep] kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] kindPrimRep doc ki - | Just ki' <- coreView ki - = kindPrimRep doc ki' -kindPrimRep doc (TyConApp typ [runtime_rep]) - = assert (typ `hasKey` tYPETyConKey) $ - runtimeRepPrimRep doc runtime_rep + | Just runtime_rep <- kindRep_maybe ki + = runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc) -- 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] -- The [PrimRep] is the final runtime representation /after/ unarisation -runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] 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) @@ -631,13 +623,13 @@ | 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 -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -primRepToRuntimeRep :: PrimRep -> Type +primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of VoidRep -> zeroBitRepTy LiftedRep -> liftedRepTy diff --git a/compiler/GHC/Types/SafeHaskell.hs b/compiler/GHC/Types/SafeHaskell.hs --- a/compiler/GHC/Types/SafeHaskell.hs +++ b/compiler/GHC/Types/SafeHaskell.hs @@ -43,7 +43,7 @@ ppr = text . show -- | Safe Haskell information for 'ModIface' --- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +-- Simply a wrapper around SafeHaskellMode to separate iface and flags newtype IfaceTrustInfo = TrustInfo SafeHaskellMode getSafeMode :: IfaceTrustInfo -> SafeHaskellMode diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -14,7 +14,7 @@ import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception -import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc) +import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault) import GHC.Utils.Outputable import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage @@ -59,7 +59,7 @@ show (SourceError msgs) = renderWithContext defaultSDocContext . vcat - . pprMsgEnvelopeBagWithLoc + . pprMsgEnvelopeBagWithLocDefault . getMessages $ msgs diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs --- a/compiler/GHC/Types/SourceText.hs +++ b/compiler/GHC/Types/SourceText.hs @@ -76,15 +76,15 @@ Motivating examples for HsLit - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` + HsChar '\n' == '\x20' + HsCharPrim '\x41'# == 'A'# HsString "\x20\x41" == " A" HsStringPrim "\x20"# == " "# HsInt 001 == 1 HsIntPrim 002# == 2# HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## + HsInt64Prim 004#Int64 == 4#Int64 + HsWord64Prim 005#Word64 == 5#Word64 HsInteger 006 == 6 For OverLitVal @@ -293,7 +293,7 @@ -- source to source manipulation tools. data StringLiteral = StringLiteral { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] + -- See Note [Literal source text] sl_fs :: FastString, -- literal string value sl_tc :: Maybe RealSrcSpan -- Location of -- possible diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -16,6 +16,7 @@ -- ** Constructing SrcLoc mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + leftmostColumn, noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler @@ -61,7 +62,7 @@ -- ** Predicates on SrcSpan isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan, - containsSpan, + containsSpan, isNoSrcSpan, -- * StringBuffer locations BufPos(..), @@ -69,6 +70,7 @@ BufSpan(..), getBufSpan, removeBufSpan, + combineBufSpans, -- * Located Located, @@ -85,9 +87,6 @@ pprLocated, pprLocatedAlways, - -- ** Modifying Located - mapLoc, - -- ** Combining and comparing Located values eqLocated, cmpLocated, cmpBufSpan, combineLocs, addCLoc, @@ -96,8 +95,6 @@ sortLocated, sortRealLocated, lookupSrcLoc, lookupSrcSpan, - liftL, - -- * Parser locations PsLoc(..), PsSpan(..), @@ -109,11 +106,6 @@ mkSrcSpanPs, combineRealSrcSpans, psLocatedToLocated, - - -- * Layout information - LayoutInfo(..), - leftmostColumn - ) where import GHC.Prelude @@ -126,12 +118,11 @@ import qualified GHC.Data.Strict as Strict import Control.DeepSeq -import Control.Applicative (liftA2) import Data.Data import Data.List (sortBy, intercalate) import Data.Function (on) import qualified Data.Map as Map -import qualified Data.Semigroup +import qualified Data.Semigroup as S {- ************************************************************************ @@ -162,7 +153,7 @@ -- -- The parser guarantees that 'BufPos' are monotonic. See #17632. This means -- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to --- have a higher 'BufPos'. Constrast that with 'RealSrcLoc', which does *not* make the +-- have a higher 'BufPos'. Contrast that with 'RealSrcLoc', which does *not* make the -- analogous guarantee about higher line/column numbers. -- -- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily @@ -247,6 +238,10 @@ mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 + getBufPos :: SrcLoc -> Strict.Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos getBufPos (UnhelpfulLoc _) = Strict.Nothing @@ -453,6 +448,10 @@ isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True isGeneratedSrcSpan _ = False +isNoSrcSpan :: SrcSpan -> Bool +isNoSrcSpan (UnhelpfulSpan UnhelpfulNoLocationInfo) = True +isNoSrcSpan _ = False + -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther @@ -639,9 +638,7 @@ -- We want to order RealSrcSpans first by the start point, then by the -- end point. instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) + compare = on compare realSrcSpanStart S.<> on compare realSrcSpanEnd instance Show RealSrcLoc where show (SrcLoc filename row col) @@ -738,13 +735,12 @@ -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) +instance (NFData l, NFData e) => NFData (GenLocated l e) where + rnf (L l e) = rnf l `seq` rnf e type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - unLoc :: GenLocated l e -> e unLoc (L _ e) = e @@ -823,10 +819,8 @@ leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering rightmost_smallest = compareSrcSpanBy (flip compare) leftmost_smallest = compareSrcSpanBy compare -leftmost_largest = compareSrcSpanBy $ \a b -> - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) +leftmost_largest = compareSrcSpanBy $ + on compare realSrcSpanStart S.<> flip (on compare realSrcSpanEnd) compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b @@ -856,11 +850,6 @@ | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && realSrcSpanEnd parent >= realSrcSpanEnd src -liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l @@ -900,33 +889,3 @@ mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) - --- | Layout information for declarations. -data LayoutInfo = - - -- | Explicit braces written by the user. - -- - -- @ - -- class C a where { foo :: a; bar :: a } - -- @ - ExplicitBraces - | - -- | Virtual braces inserted by the layout algorithm. - -- - -- @ - -- class C a where - -- foo :: a - -- bar :: a - -- @ - VirtualBraces - !Int -- ^ Layout column (indentation level, begins at 1) - | - -- | Empty or compiler-generated blocks do not have layout information - -- associated with them. - NoLayoutInfo - - deriving (Eq, Ord, Show, Data) - --- | Indentation level is 1-indexed, so the leftmost column is 1. -leftmostColumn :: Int -leftmostColumn = 1 diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs --- a/compiler/GHC/Types/TyThing.hs +++ b/compiler/GHC/Types/TyThing.hs @@ -183,9 +183,8 @@ implicitCoTyCon tc ++ -- for each data constructor in order, - -- the constructor, worker, and (possibly) wrapper - [ thing | dc <- tyConDataCons tc - , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- the constructor and associated implicit 'Id's + datacon_stuff -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where @@ -193,6 +192,23 @@ Nothing -> [] Just cl -> implicitClassThings cl + -- For each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + -- + -- If the data constructor is in a "type data" declaration, + -- promote it to the type level now. + -- See Note [Type data declarations] in GHC.Rename.Module. + datacon_stuff :: [TyThing] + datacon_stuff + | isTypeDataTyCon tc = [ATyCon (promoteDataCon dc) | dc <- cons] + | otherwise + = [ty_thing | dc <- cons, + ty_thing <- AConLike (RealDataCon dc) : + dataConImplicitTyThings dc] + + cons :: [DataCon] + cons = tyConDataCons tc + -- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc @@ -223,9 +239,19 @@ tyThingParent_maybe (AConLike cl) = case cl of RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) PatSynCon{} -> Nothing -tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just tc -> Just (ATyCon tc) - Nothing -> Nothing +tyThingParent_maybe (ATyCon tc) + | -- Special case for `type data` data constructors. They appear as an + -- ATyCon (not ADataCon) but we want to display them here as if they were + -- a DataCon (i.e. with the parent declaration) (#22817). + -- See Note [Type data declarations] in GHC.Rename.Module. + Just dc <- isPromotedDataCon_maybe tc + , let parent_tc = dataConTyCon dc + , isTypeDataTyCon parent_tc + = Just (ATyCon parent_tc) + | Just tc <- tyConAssoc_maybe tc + = Just (ATyCon tc) + | otherwise + = Nothing tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = RecSelData tc } -> Just (ATyCon tc) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -59,6 +59,8 @@ import Data.Char ( chr, ord ) +import Language.Haskell.Syntax.Module.Name + {- ************************************************************************ * * @@ -75,7 +77,7 @@ The mask is typically an ASCII character. It is typically used to make it easier to distinguish uniques constructed by different parts of the compiler. There is a (potentially incomplete) list of unique masks used given in -GHC.Builtin.Uniques. See Note [Uniques-prelude - Uniques for wired-in Prelude things] +GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known masks] `mkUnique` constructs a `Unique` from its pieces mkUnique :: Char -> Int -> Unique @@ -187,6 +189,10 @@ instance Uniquable Int where getUnique i = mkUniqueGrimily i +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + + {- ************************************************************************ * * @@ -275,13 +281,15 @@ = case unpkUnique uniq of (tag, u) -> tag : iToBase62 u -pprUniqueAlways :: Unique -> SDoc +pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques -- It replaces the old pprUnique to remind callers that -- they should consider whether they want to consult -- Opt_SuppressUniques pprUniqueAlways u = text (showUnique u) +{-# SPECIALIZE pprUniqueAlways :: Unique -> SDoc #-} +{-# SPECIALIZE pprUniqueAlways :: Unique -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Outputable Unique where ppr = pprUniqueAlways diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -58,6 +58,7 @@ udfmMinusUFM, ufmMinusUDFM, partitionUDFM, udfmRestrictKeys, + udfmRestrictKeysSet, anyUDFM, allUDFM, pprUniqDFM, pprUDFM, @@ -81,6 +82,7 @@ import Data.Function (on) import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) import Unsafe.Coerce +import qualified Data.IntSet as I -- Note [Deterministic UniqFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -300,9 +302,13 @@ 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 @@ -313,6 +319,11 @@ udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i + +udfmRestrictKeysSet :: UniqDFM key elt -> I.IntSet -> UniqDFM key elt +udfmRestrictKeysSet (UDFM val_set i) set = + let key_set = set + in UDFM (M.restrictKeys val_set key_set) i -- | Converts `UniqDFM` to a list, with elements in deterministic order. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -40,7 +40,7 @@ listToUFM_Directly, listToUFM_C, listToIdentityUFM, - addToUFM,addToUFM_C,addToUFM_Acc, + addToUFM,addToUFM_C,addToUFM_Acc,addToUFM_L, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -182,6 +182,24 @@ -> UniqFM key elts -- result addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUFM_L + :: Uniquable key + => (key -> elt -> elt -> elt) -- key,old,new + -> key + -> elt -- new + -> UniqFM key elt + -> (Maybe elt, UniqFM key elt) -- old, result +addToUFM_L f k v (UFM m) = + coerce $ + M.insertLookupWithKey + (\_ _n _o -> f k _o _n) + (getKey $ getUnique k) + v + m alterUFM :: Uniquable key diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -20,6 +20,7 @@ addListToUniqMap, addToUniqMap_C, addToUniqMap_Acc, + addToUniqMap_L, alterUniqMap, addListToUniqMap_C, adjustUniqMap, @@ -31,6 +32,7 @@ plusUniqMapList, minusUniqMap, intersectUniqMap, + intersectUniqMap_C, disjointUniqMap, mapUniqMap, filterUniqMap, @@ -57,9 +59,10 @@ import Data.Coerce import Data.Maybe import Data.Data +import Control.DeepSeq -- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM k (k, a)) +newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } deriving (Data, Eq, Functor) type role UniqMap nominal representational @@ -76,6 +79,9 @@ [ ppr k <+> text "->" <+> ppr v | (k, v) <- nonDetEltsUFM m ] +instance (NFData k, NFData a) => NFData (UniqMap k a) where + rnf (UniqMap fm) = seqEltsUFM rnf fm + liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) liftC f (_, v) (k', v') = (k', f v v') @@ -123,6 +129,22 @@ (\b -> (k0, new b)) m k0 v0 +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUniqMap_L :: Uniquable k + => (k -> a -> a -> a) -- key,old,new + -> k + -> a -- new + -> UniqMap k a + -> (Maybe a, UniqMap k a) +addToUniqMap_L f k v (UniqMap m) = case addToUFM_L + (\_k (_, _o) (_, _n) -> (_k, f _k _o _n)) + k + (k, v) + m of + (_maybe, _ufm) -> (snd <$> _maybe, UniqMap _ufm) + alterUniqMap :: Uniquable k => (Maybe a -> Maybe a) -> UniqMap k a @@ -175,6 +197,10 @@ intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 + +-- | Intersection with a combining function. +intersectUniqMap_C :: (a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c +intersectUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM_C (\(k, a) (_, b) -> (k, f a b)) m1 m2 disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs --- a/compiler/GHC/Types/Unique/Supply.hs +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -98,7 +98,7 @@ the same mask 's'. However in some places we create a unique supply using `mkSplitUniqSupply` and thread it through the code, while in GHC.Core.Opt.Simplify.Monad we use the `instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM -and `uniqFromMask` in getUniqeM. +and `uniqFromMask` in getUniqueM. Ultimately all these boil down to each new unique consisting of the mask and the result from a call to `genSym`. The later producing a distinct number for each invocation ensuring @@ -158,7 +158,7 @@ benefits of threading the mask this *also* has the benefit of avoiding the mask getting captured in thunks, or being passed around at runtime. It does however come at the cost of having to use a fixed Mask for all -code run in this Monad. But rememeber, the Mask is purely cosmetic: +code run in this Monad. But remember, the Mask is purely cosmetic: See Note [Uniques and masks]. NB: It's *not* an optimization to pass around the UniqSupply inside an diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | @@ -66,20 +65,34 @@ 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, - mapVarBndr, mapVarBndrs, lookupVarBndr, + mapVarBndr, mapVarBndrs, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -96,7 +109,7 @@ 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 +118,7 @@ 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 +443,20 @@ {- ********************************************************************* * * -* 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 +467,27 @@ -- 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 +-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? +isVisibleForAllTyFlag :: ForAllTyFlag -> Bool +isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) -isInferredArgFlag :: ArgFlag -> Bool --- More restrictive than isInvisibleArgFlag -isInferredArgFlag (Invisible InferredSpec) = True -isInferredArgFlag _ = False +-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? +isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool +isInvisibleForAllTyFlag (Invisible {}) = True +isInvisibleForAllTyFlag Required = 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 +isInferredForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isInferredForAllTyFlag (Invisible InferredSpec) = True +isInferredForAllTyFlag _ = False -instance Outputable ArgFlag where +instance Outputable ForAllTyFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" @@ -496,7 +502,7 @@ 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 +514,111 @@ 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 -{- Note [AnonArgFlag] +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 [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 +654,7 @@ {- ********************************************************************* * * -* VarBndr, TyCoVarBinder +* VarBndr, ForAllTyBinder * * ********************************************************************* -} @@ -600,29 +663,29 @@ 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 +696,29 @@ -- | 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 () -tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] +type TyVarBinder = VarBndr TyVar ForAllTyFlag +type InvisTVBinder = VarBndr TyVar Specificity +type ReqTVBinder = VarBndr TyVar () + +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 +727,21 @@ 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,29 +751,21 @@ 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) -lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag -lookupVarBndr var bndrs = lookup var zipped_bndrs - where - zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs - -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) @@ -716,6 +780,270 @@ 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 --- a/compiler/GHC/Types/Var.hs-boot +++ b/compiler/GHC/Types/Var.hs-boot @@ -9,8 +9,8 @@ -- 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 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -9,7 +9,7 @@ -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, + elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, @@ -23,7 +23,7 @@ isEmptyVarEnv, elemVarEnvByKey, filterVarEnv, restrictVarEnv, - partitionVarEnv, + partitionVarEnv, varEnvDomain, -- * Deterministic Var environments (maps) DVarEnv, DIdEnv, DTyVarEnv, @@ -47,10 +47,10 @@ anyDVarEnv, -- * The InScopeSet type - InScopeSet, + InScopeSet(..), -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, + emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, unionInScope, elemInScopeSet, uniqAway, @@ -62,7 +62,8 @@ -- ** Operations on RnEnv2s mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, anyInRnEnvR, + rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, extendRnInScopeSetList, @@ -82,6 +83,7 @@ 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 @@ -148,6 +150,9 @@ mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet in_scope = InScope in_scope +mkInScopeSetList :: [Var] -> InScopeSet +mkInScopeSetList vs = InScope (mkVarSet vs) + extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope) v = InScope (extendVarSet in_scope v) @@ -400,6 +405,14 @@ inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env +-- | `anyInRnEnvR env set` == `any (inRnEnvR rn_env) (toList set)` +-- but lazy in the second argument if the right side of the env is empty. +anyInRnEnvR :: RnEnv2 -> VarSet -> Bool +anyInRnEnvR (RV2 { envR = env }) vs + -- Avoid allocating the predicate if we deal with an empty env. + | isEmptyVarEnv env = False + | otherwise = anyVarSet (`elemVarEnv` env) vs + lookupRnInScope :: RnEnv2 -> Var -> Var lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v @@ -493,8 +506,10 @@ 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 restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a @@ -509,6 +524,7 @@ lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +anyVarEnv :: (elt -> Bool) -> UniqFM key elt -> Bool lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool @@ -539,6 +555,7 @@ lookupVarEnv = lookupUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv = filterUFM +anyVarEnv = anyUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM @@ -546,8 +563,10 @@ emptyVarEnv = emptyUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM -partitionVarEnv = partitionUFM +partitionVarEnv = partitionUFM +varEnvDomain = domUFMUnVarSet + restrictVarEnv env vs = filterUFM_Directly keep env where keep u _ = u `elemVarSetByKey` vs @@ -556,6 +575,7 @@ lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx Nothing -> panic "lookupVarEnv_NF: Nothing" + {- @modifyVarEnv@: Look up a thing in the VarEnv, diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs --- a/compiler/GHC/Unit.hs +++ b/compiler/GHC/Unit.hs @@ -144,7 +144,7 @@ You can think of this as polymorphism at the module level: module signatures give constraints on the "type" of module that can be used to fill the hole -(where "type" means types of the exported module entitites, etc.). +(where "type" means types of the exported module entities, etc.). Module signatures contain enough information (datatypes, abstract types, type synonyms, classes, etc.) to typecheck modules depending on them but not diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -3,8 +3,10 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv + , ueEPS , unsafeGetHomeUnit , updateHug + , updateHpt_lazy , updateHpt -- * Unit Env helper functions , ue_units @@ -36,6 +38,7 @@ , addHomeModInfoToHug -- * UnitEnvGraph , UnitEnvGraph (..) + , UnitEnvGraphKey , unitEnv_insert , unitEnv_delete , unitEnv_adjust @@ -49,6 +52,7 @@ , unitEnv_elts , unitEnv_hpts , unitEnv_foldWithKey + , unitEnv_union , unitEnv_mapWithKey -- * Invariants , assertUnitEnvInvariant @@ -99,6 +103,9 @@ -- ^ GHC name/version (used for dynamic library suffix) } +ueEPS :: UnitEnv -> IO ExternalPackageState +ueEPS = eucEPS . ue_eps + initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache @@ -116,6 +123,9 @@ unsafeGetHomeUnit :: UnitEnv -> HomeUnit unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue +updateHpt_lazy :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv +updateHpt_lazy = ue_updateHPT_lazy + updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv updateHpt = ue_updateHPT @@ -263,7 +273,9 @@ go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue) updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv -updateHueHpt f hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue)} +updateHueHpt f hue = + let !hpt = f (homeUnitEnv_hpt hue) + in hue { homeUnitEnv_hpt = hpt } lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo @@ -339,6 +351,9 @@ unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g +unitEnv_union :: (a -> a -> a) -> UnitEnvGraph a -> UnitEnvGraph a -> UnitEnvGraph a +unitEnv_union f (UnitEnvGraph env1) (UnitEnvGraph env2) = UnitEnvGraph (Map.unionWith f env1 env2) + -- ------------------------------------------------------- -- Query and modify UnitState in HomeUnitEnv -- ------------------------------------------------------- @@ -366,16 +381,26 @@ ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv +ue_updateHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv +ue_updateHPT_lazy f e = ue_updateUnitHPT_lazy f (ue_currentUnit e) e + ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateHUG f e = ue_updateUnitHUG f e +ue_updateUnitHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv +ue_updateUnitHPT_lazy f uid ue_env = ue_updateHomeUnitEnv update uid ue_env + where + update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv } + ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env where - update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv } + update unitEnv = + let !res = f $ homeUnitEnv_hpt unitEnv + in unitEnv { homeUnitEnv_hpt = res } ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)} @@ -531,7 +556,7 @@ a unit is identified by the -this-unit-id flag and dependencies specified by the normal -package-id flag. 2. Downsweep is augmented to know to know how to look for dependencies in any home unit. -3. The rest of the compiler is modified appropiately to offset paths to the right places. +3. The rest of the compiler is modified appropriately to offset paths to the right places. 4. --make mode can parallelise between home units and multiple units are allowed to produce linkables. Closure Property @@ -548,12 +573,12 @@ Offsetting Paths ---------------- -The main complication to the implementation is to do with offsetting paths appropiately. +The main complication to the implementation is to do with offsetting paths appropriately. For a long time it has been assumed that GHC will execute in the top-directory for a unit, normally where the .cabal file is and all paths are interpreted relative to there. When you have multiple home units then it doesn't make sense to pick one of these units to choose as the base-unit, and you can't robustly change directories when -using parralelism. +using parallelism. Therefore there is an option `-working-directory`, which tells GHC where the relative paths for each unit should be interpreted relative to. For example, if you specify diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs --- a/compiler/GHC/Unit/External.hs +++ b/compiler/GHC/Unit/External.hs @@ -1,6 +1,7 @@ module GHC.Unit.External ( ExternalUnitCache (..) , initExternalUnitCache + , eucEPS , ExternalPackageState (..) , initExternalPackageState , EpsStats(..) @@ -20,11 +21,10 @@ import GHC.Unit import GHC.Unit.Module.ModIface -import GHC.Core ( RuleBase ) import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) import GHC.Core.Opt.ConstantFold -import GHC.Core.Rules (mkRuleBase) +import GHC.Core.Rules ( RuleBase, mkRuleBase) import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch @@ -59,6 +59,9 @@ initExternalUnitCache :: IO ExternalUnitCache initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState +eucEPS :: ExternalUnitCache -> IO ExternalPackageState +eucEPS = readIORef . euc_eps + initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { eps_is_boot = emptyInstalledModuleEnv @@ -151,7 +154,7 @@ eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them - eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + eps_stats :: !EpsStats -- ^ Statistics about what was loaded from external packages } -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -33,8 +33,9 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import Data.Maybe + +import Language.Haskell.Syntax.Module.Name -- | Information about the home unit (i.e., the until that will contain the -- modules we are compiling) diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs --- a/compiler/GHC/Unit/Home/ModInfo.hs +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -1,6 +1,13 @@ -- | Info about modules in the "home" unit module GHC.Unit.Home.ModInfo ( HomeModInfo (..) + , HomeModLinkable(..) + , homeModInfoObject + , homeModInfoByteCode + , emptyHomeModInfoLinkable + , justBytecode + , justObjects + , bytecodeAndObjects , HomePackageTable , emptyHomePackageTable , lookupHpt @@ -27,7 +34,7 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module -import GHC.Linker.Types ( Linkable(..) ) +import GHC.Linker.Types ( Linkable(..), isObjectLinkable ) import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -35,6 +42,7 @@ import GHC.Utils.Outputable import Data.List (sortOn) import Data.Ord +import GHC.Utils.Panic -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo @@ -48,24 +56,77 @@ -- This field is LAZY because a ModDetails is constructed by knot tying. - , hm_linkable :: !(Maybe Linkable) + , hm_linkable :: !HomeModLinkable -- ^ The actual artifact we would like to link to access things in - -- this module. + -- this module. See Note [Home module build products] -- - -- 'hm_linkable' might be Nothing: + -- 'hm_linkable' might be empty: -- -- 1. If this is an .hs-boot module -- -- 2. Temporarily during compilation if we pruned away -- the old linkable because it was out of date. -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields - -- in the 'HomePackageTable' will be @Just@. - -- -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the -- 'HomeModInfo' by building a new 'ModDetails' from the old -- 'ModIface' (only). } + +homeModInfoByteCode :: HomeModInfo -> Maybe Linkable +homeModInfoByteCode = homeMod_bytecode . hm_linkable + +homeModInfoObject :: HomeModInfo -> Maybe Linkable +homeModInfoObject = homeMod_object . hm_linkable + +emptyHomeModInfoLinkable :: HomeModLinkable +emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing + +-- See Note [Home module build products] +data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) + , homeMod_object :: !(Maybe Linkable) } + +instance Outputable HomeModLinkable where + ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 + +justBytecode :: Linkable -> HomeModLinkable +justBytecode lm = + assertPpr (not (isObjectLinkable lm)) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } + +justObjects :: Linkable -> HomeModLinkable +justObjects lm = + assertPpr (isObjectLinkable lm) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_object = Just lm } + +bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable +bytecodeAndObjects bc o = + assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o) + (HomeModLinkable (Just bc) (Just o)) + + +{- +Note [Home module build products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When compiling a home module we can produce some combination of the following +build products. + +1. A byte code linkable, for use with the byte code interpreter. +2. An object file linkable, for linking a final executable or the byte code interpreter + +What we have produced is recorded in the `HomeModLinkable` type. In the case +that these linkables are produced they are stored in the relevant field so that +subsequent modules can retrieve and use them as necessary. + +* `-fbyte-code` will *only* produce a byte code linkable. This is the default in GHCi. +* `-fobject-code` will *only* produce an object file linkable. This is the default in -c and --make mode. +* `-fbyte-code-and-object-code` produces both a byte-code and object file linkable. So both fields are populated. + +Why would you want to produce both an object file and byte code linkable? If you +also want to use `-fprefer-byte-code` then you should probably also use this +flag to make sure that byte code is generated for your modules. + +-} -- | Helps us find information about modules in the home package type HomePackageTable = DModuleNameEnv HomeModInfo diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -18,7 +18,7 @@ ( module GHC.Unit.Types -- * The ModuleName type - , module GHC.Unit.Module.Name + , module Language.Haskell.Syntax.Module.Name -- * The ModLocation type , module GHC.Unit.Module.Location @@ -47,11 +47,13 @@ import GHC.Types.Unique.DSet import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Unit.Module.Location import GHC.Unit.Module.Env -import GHC.Utils.Misc +import Language.Haskell.Syntax.Module.Name + +import Data.Semigroup + -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles @@ -68,9 +70,7 @@ -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) +stableModuleCmp (Module p1 n1) (Module p2 n2) = stableUnitCmp p1 p2 <> stableModuleNameCmp n1 n2 class ContainsModule t where extractModule :: t -> Module diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -24,7 +24,6 @@ import GHC.Types.SafeHaskell import GHC.Types.Name -import GHC.Unit.Module.Name import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs --- a/compiler/GHC/Unit/Module/Env.hs +++ b/compiler/GHC/Unit/Module/Env.hs @@ -9,7 +9,7 @@ , partitionModuleEnv , moduleEnvKeys, moduleEnvElts, moduleEnvToList , unitModuleEnv, isEmptyModuleEnv - , extendModuleEnvWith, filterModuleEnv + , extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv -- * ModuleName mappings , ModuleNameEnv, DModuleNameEnv @@ -37,12 +37,10 @@ import GHC.Prelude -import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Unit.Types -import GHC.Utils.Misc import Data.List (sortBy, sort) import Data.Ord @@ -51,9 +49,12 @@ import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Semigroup as S import qualified GHC.Data.FiniteMap as Map import GHC.Utils.Outputable +import Language.Haskell.Syntax.Module.Name + -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) @@ -72,7 +73,7 @@ ordering on Module and normalizes by doing the lexicographic sort when turning the env to a list. See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why +nondeterminism and Note [Deterministic UniqFM] for explanation of why it matters for maps. -} @@ -86,12 +87,16 @@ instance Ord NDModule where compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique p1 `nonDetCmpUnique` getUnique p2) S.<> (getUnique n1 `nonDetCmpUnique` getUnique n2) filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +mapMaybeModuleEnv :: (Module -> a -> Maybe b) -> ModuleEnv a -> ModuleEnv b +mapMaybeModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.mapMaybeWithKey (f . unNDModule) e) elemModuleEnv :: Module -> ModuleEnv a -> Bool elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -29,6 +29,7 @@ , NodeKey(..) , nodeKeyUnitId + , nodeKeyModName , ModNodeKey , mkNodeKey , msKey @@ -41,6 +42,7 @@ where import GHC.Prelude +import GHC.Platform import qualified GHC.LanguageExtensions as LangExt @@ -48,7 +50,6 @@ import GHC.Data.Graph.Directed import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Types.SourceFile ( hscSourceString ) @@ -126,6 +127,10 @@ nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk nodeKeyUnitId (NodeKey_Link uid) = uid +nodeKeyModName :: NodeKey -> Maybe ModuleName +nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk) +nodeKeyModName _ = Nothing + data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot , mnkUnitId :: !UnitId } deriving (Eq, Ord) @@ -258,7 +263,8 @@ _ -> False platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) in text exe_file showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit @@ -273,17 +279,16 @@ where op = normalise - mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = moduleNameString (moduleName (ms_mod mod_summary)) ++ + hscSourceString (ms_hsc_src mod_summary) dyn_file = op $ msDynObjFilePath mod_summary obj_file = op $ msObjFilePath mod_summary - message = case backend dflags of - Interpreter | recomp -> text "interpreted" - NoBackend -> text "nothing" - _ -> - if gopt Opt_BuildDynamicToo dflags - then text obj_file <> comma <+> text dyn_file - else text obj_file + files = [ obj_file ] + ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] + message = case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -128,11 +128,11 @@ -- | Selects a IfaceDecl representation. -- For fully instantiated interfaces we also maintain -- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) where +type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where IfaceDeclExts 'ModIfaceCore = IfaceDecl IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) -type family IfaceBackendExts (phase :: ModIfacePhase) where +type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where IfaceBackendExts 'ModIfaceCore = () IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend @@ -200,6 +200,11 @@ -- Ditto data constructors, class operations, except that -- the hash of the parent class/tycon changes + mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo], + -- ^ Extra variable definitions which are **NOT** exposed but when + -- combined with mi_decls allows us to restart code generation. + -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] + mi_globals :: !(Maybe GlobalRdrEnv), -- ^ Binds all the things defined at the top level in -- the /original source/ code for this module. which @@ -235,7 +240,7 @@ -- See Note [Trust Own Package] in GHC.Rename.Names mi_complete_matches :: ![IfaceCompleteMatch], - mi_docs :: Maybe Docs, + mi_docs :: !(Maybe Docs), -- ^ Docstrings and related data for use by haddock, the ghci -- @:doc@ command, and other tools. -- @@ -349,6 +354,7 @@ mi_warns = warns, mi_anns = anns, mi_decls = decls, + mi_extra_decls = extra_decls, mi_insts = insts, mi_fam_insts = fam_insts, mi_rules = rules, @@ -392,6 +398,7 @@ lazyPut bh warns lazyPut bh anns put_ bh decls + put_ bh extra_decls put_ bh insts put_ bh fam_insts lazyPut bh rules @@ -423,6 +430,7 @@ warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh + extra_decls <- get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh @@ -446,6 +454,7 @@ mi_fixities = fixities, mi_warns = warns, mi_decls = decls, + mi_extra_decls = extra_decls, mi_globals = Nothing, mi_insts = insts, mi_fam_insts = fam_insts, @@ -494,6 +503,7 @@ mi_fam_insts = [], mi_rules = [], mi_decls = [], + mi_extra_decls = Nothing, mi_globals = Nothing, mi_hpc = False, mi_trust = noIfaceTrustInfo, @@ -541,11 +551,12 @@ -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` - f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` - rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 + f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` + rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24 `seq` () + instance NFData (ModIfaceBackend) where rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs --- a/compiler/GHC/Unit/Module/ModSummary.hs +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -76,7 +76,7 @@ ms_textual_imps :: [(PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* ms_ghc_prim_import :: !Bool, - -- ^ Whether the special module GHC.Prim was imported explicitliy + -- ^ Whether the special module GHC.Prim was imported explicitly ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. diff --git a/compiler/GHC/Unit/Module/Name.hs b/compiler/GHC/Unit/Module/Name.hs deleted file mode 100644 --- a/compiler/GHC/Unit/Module/Name.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | The ModuleName type -module GHC.Unit.Module.Name - ( ModuleName - , pprModuleName - , moduleNameFS - , moduleNameString - , moduleNameSlashes, moduleNameColons - , mkModuleName - , mkModuleNameFS - , stableModuleNameCmp - , parseModuleName - ) -where - -import GHC.Prelude - -import GHC.Utils.Outputable -import GHC.Types.Unique -import GHC.Data.FastString -import GHC.Utils.Binary -import GHC.Utils.Misc - -import Control.DeepSeq -import Data.Data -import System.FilePath - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP) -import Data.Char (isAlphaNum) - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString deriving Show - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - diff --git a/compiler/GHC/Unit/Module/Name.hs-boot b/compiler/GHC/Unit/Module/Name.hs-boot deleted file mode 100644 --- a/compiler/GHC/Unit/Module/Name.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Unit.Module.Name where - -import GHC.Prelude () - -data ModuleName - diff --git a/compiler/GHC/Unit/Module/Status.hs b/compiler/GHC/Unit/Module/Status.hs --- a/compiler/GHC/Unit/Module/Status.hs +++ b/compiler/GHC/Unit/Module/Status.hs @@ -10,13 +10,13 @@ import GHC.Unit.Module.ModIface import GHC.Utils.Fingerprint -import GHC.Linker.Types import GHC.Utils.Outputable +import GHC.Unit.Home.ModInfo -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface (Maybe Linkable) + = HscUpToDate ModIface HomeModLinkable -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs --- a/compiler/GHC/Unit/Module/Warnings.hs +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,6 +30,7 @@ import Language.Haskell.Syntax.Extension import Data.Data +import GHC.Generics ( Generic ) -- | Warning Text -- @@ -40,6 +42,7 @@ | DeprecatedTxt (Located SourceText) [Located (WithHsDocIdentifiers StringLiteral pass)] + deriving Generic deriving instance Eq (IdP pass) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) @@ -58,21 +61,21 @@ instance Binary (WarningTxt GhcRn) where put_ bh (WarningTxt s w) = do putByte bh 0 - put_ bh s - put_ bh w + put_ bh $ unLoc s + put_ bh $ unLoc <$> w put_ bh (DeprecatedTxt s d) = do putByte bh 1 - put_ bh s - put_ bh d + put_ bh $ unLoc s + put_ bh $ unLoc <$> d get bh = do h <- getByte bh case h of - 0 -> do s <- get bh - w <- get bh + 0 -> do s <- noLoc <$> get bh + w <- fmap noLoc <$> get bh return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh + _ -> do s <- noLoc <$> get bh + d <- fmap noLoc <$> get bh return (DeprecatedTxt s d) diff --git a/compiler/GHC/Unit/Module/WholeCoreBindings.hs b/compiler/GHC/Unit/Module/WholeCoreBindings.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Unit/Module/WholeCoreBindings.hs @@ -0,0 +1,63 @@ +module GHC.Unit.Module.WholeCoreBindings where + +import GHC.Unit.Types (Module) +import GHC.Unit.Module.Location +import GHC.Iface.Syntax + +{- +Note [Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A interface file can optionally contain the definitions of all core bindings, this +is enabled by the flag `-fwrite-if-simplified-core`. +This provides everything needed in addition to the normal ModIface and ModDetails +to restart compilation after typechecking to generate bytecode. The `fi_bindings` field +is stored in the normal interface file and the other fields populated whilst loading +the interface file. + +The lifecycle of a WholeCoreBindings typically proceeds as follows: + +1. The ModIface which contains mi_extra_decls is loaded from disk. A linkable is + created (which is headed by the `CoreBindings` constructor). This is an unhydrated set of bindings which + is currently unsuitable for linking, but at the point it is loaded, the ModIface + hasn't been hydrated yet (See Note [Hydrating Modules]) either so the CoreBindings constructor allows the delaying of converting + the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also + allows us to convert the WholeCoreBindings into multiple different linkables if we so desired. + +2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together + all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to + create the linkable. The linkable created is a "LoadedBCOs" linkable, which + was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly. + Using the `BCOs` constructor directly here leads to the bytecode being forced + too eagerly. + +3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and + the linkable is used as before. + +The flag `-fwrite-if-simplified-core` determines whether the extra information is written +to an interface file. The program which is written is the core bindings of the module +after whatever simplification the user requested has been performed. So the simplified core bindings +of the interface file agree with the optimisation level as reported by the interface +file. + +Note [Size of Interface Files with Core Definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +How much overhead does `-fwrite-if-simplified-core` add to a typical interface file? +As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with + +| Project | .hi | .hi (fat) | .o | +| --------| ---- | --------- | -- | +| ghc | 32M | 68M | 127M | +| Cabal | 3.2M | 9.8M | 14M | + +So the interface files gained in size but the end result was still smaller than +the object files. + +-} + +data WholeCoreBindings = WholeCoreBindings + { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings. + , wcb_module :: Module -- ^ The module which the bindings are for + , wcb_mod_location :: ModLocation -- ^ The location where the sources reside. + } diff --git a/compiler/GHC/Unit/Parser.hs b/compiler/GHC/Unit/Parser.hs --- a/compiler/GHC/Unit/Parser.hs +++ b/compiler/GHC/Unit/Parser.hs @@ -10,13 +10,14 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Data.FastString import qualified Text.ParserCombinators.ReadP as Parse import Text.ParserCombinators.ReadP (ReadP, (<++)) import Data.Char (isAlphaNum) +import Language.Haskell.Syntax.Module.Name (ModuleName, parseModuleName) + parseUnit :: ReadP Unit parseUnit = parseVirtUnitId <++ parseDefUnitId where @@ -54,5 +55,4 @@ _ <- Parse.char '=' v <- parseHoleyModule return (k, v) - diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -538,13 +538,13 @@ lookupUnitId' db uid = Map.lookup uid db --- | Looks up the given unit in the unit state, panicing if it is not found +-- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of Just info -> info Nothing -> pprPanic "unsafeLookupUnit" (ppr u) --- | Looks up the given unit id in the unit state, panicing if it is not found +-- | Looks up the given unit id in the unit state, panicking if it is not found unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo unsafeLookupUnitId state uid = case lookupUnitId state uid of Just info -> info @@ -711,8 +711,8 @@ let base_conf_refs = case e_pkg_path of Left _ -> system_conf_refs Right path - | not (null path) && isSearchPathSeparator (last path) - -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs | otherwise -> map PkgDbPath (splitSearchPath path) @@ -1117,31 +1117,29 @@ -- available. -- findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = - let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = - [ p | p <- all_ps - , Map.member (mkUnit p) vis_map ] in - case all_exposed_ps of - [] -> case all_ps of - [] -> notfound - many -> pick (head (sortByPreference prec_map many)) - many -> pick (head (sortByPreference prec_map many)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + notfound = do debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " not found." return Nothing - pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo)) + pick :: UnitInfo -> IO (UnitId, UnitInfo) pick pkg = do debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " mapped to " <> ppr (unitId pkg) - return (Just (wired_pkg, pkg)) + return (wired_pkg, pkg) mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds @@ -2050,7 +2048,7 @@ instance Outputable UnitErr where ppr = \case CloseUnitErr p mb_parent - -> (ftext (fsLit "unknown unit:") <+> ppr p) + -> (text "unknown unit:" <+> ppr p) <> case mb_parent of Nothing -> Outputable.empty Just parent -> space <> parens (text "dependency of" diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} @@ -48,6 +50,7 @@ , stableUnitCmp , unitIsDefinite , isHoleUnit + , pprUnit -- * Unit Ids , unitIdString @@ -87,9 +90,9 @@ where import GHC.Prelude + import GHC.Types.Unique import GHC.Types.Unique.DSet -import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString @@ -105,6 +108,9 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 +import Language.Haskell.Syntax.Module.Name +import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..)) + --------------------------------------------------------------------- -- MODULES --------------------------------------------------------------------- @@ -158,19 +164,24 @@ ppr = pprInstantiatedModule instance Outputable InstantiatedUnit where - ppr uid = + ppr = pprInstantiatedUnit + +pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc +pprInstantiatedUnit uid = -- getPprStyle $ \sty -> - ppr cid <> + pprUnitId cid <> (if not (null insts) -- pprIf then brackets (hcat (punctuate comma $ - [ ppr modname <> text "=" <> pprModule m + [ pprModuleName modname <> text "=" <> pprModule m | (modname, m) <- insts])) else empty) where cid = instUnitInstanceOf uid insts = instUnitInsts uid +{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-} +{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) -- @@ -191,8 +202,8 @@ unitFS (RealUnit (Definite x)) = unitFS x unitFS HoleUnit = holeFS -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc +pprModule :: IsLine doc => Module -> doc +pprModule mod@(Module p n) = docWithContext (doc . sdocStyle) where doc sty | codeStyle sty = @@ -203,10 +214,11 @@ | qualModule sty mod = case p of HoleUnit -> angleBrackets (pprModuleName n) - _ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n + _ -> pprUnit p <> char ':' <> pprModuleName n | otherwise = pprModuleName n - +{-# SPECIALIZE pprModule :: Module -> SDoc #-} +{-# SPECIALIZE pprModule :: Module -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable pprInstantiatedModule :: InstantiatedModule -> SDoc pprInstantiatedModule (Module uid m) = @@ -340,10 +352,12 @@ instance Outputable Unit where ppr pk = pprUnit pk -pprUnit :: Unit -> SDoc -pprUnit (RealUnit uid) = ppr uid -pprUnit (VirtUnit uid) = ppr uid +pprUnit :: IsLine doc => Unit -> doc +pprUnit (RealUnit (Definite d)) = pprUnitId d +pprUnit (VirtUnit uid) = pprInstantiatedUnit uid pprUnit HoleUnit = ftext holeFS +{-# SPECIALIZE pprUnit :: Unit -> SDoc #-} +{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Show Unit where show = unitString @@ -519,9 +533,15 @@ getUnique = getUnique . unitIdFS instance Outputable UnitId where - ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId] - -- in "GHC.Unit" + ppr = pprUnitId +pprUnitId :: IsLine doc => UnitId -> doc +pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs) + -- see Note [Pretty-printing UnitId] in GHC.Unit + -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable +{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-} +{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated -- code for. @@ -632,13 +652,6 @@ -- themselves, however, one should use not 'IsBoot' or conflate signatures and -- modules in opposition to boot interfaces. Instead, one should use -- 'DriverPhases.HscSource'. See Note [HscSource types]. - --- | Indicates whether a module name is referring to a boot interface (hs-boot --- file) or regular module (hs file). We need to treat boot modules specially --- when building compilation graphs, since they break cycles. Regular source --- files and signature files are treated equivalently. -data IsBootInterface = NotBoot | IsBoot - deriving (Eq, Ord, Show, Data) instance Binary IsBootInterface where put_ bh ib = put_ bh $ diff --git a/compiler/GHC/Unit/Types.hs-boot b/compiler/GHC/Unit/Types.hs-boot --- a/compiler/GHC/Unit/Types.hs-boot +++ b/compiler/GHC/Unit/Types.hs-boot @@ -1,9 +1,8 @@ {-# LANGUAGE KindSignatures #-} module GHC.Unit.Types where -import GHC.Prelude () -import {-# SOURCE #-} GHC.Utils.Outputable -import {-# SOURCE #-} GHC.Unit.Module.Name ( ModuleName ) +-- No Prelude. See Note [Exporting pprTrace from GHC.Prelude] +import Language.Haskell.Syntax.Module.Name (ModuleName) import Data.Kind (Type) data UnitId @@ -15,4 +14,3 @@ moduleName :: GenModule a -> ModuleName moduleUnit :: GenModule a -> a -pprModule :: Module -> SDoc diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -34,6 +34,7 @@ SymbolTable, Dictionary, BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, openBinMem, -- closeBin, @@ -47,8 +48,10 @@ writeBinMem, readBinMem, + readBinMemN, putAt, getAt, + forwardPut, forwardPut_, forwardGet, -- * For writing instances putByte, @@ -71,12 +74,20 @@ -- * User data UserData(..), getUserData, setUserData, - newReadState, newWriteState, + newReadState, newWriteState, noUserData, + + -- * String table ("dictionary") putDictionary, getDictionary, putFS, + FSTable, initFSTable, getDictFastString, putDictFastString, + + -- * Newtype wrappers + BinSpan(..), BinSrcSpan(..), BinLocated(..) ) where import GHC.Prelude +import Language.Haskell.Syntax.Module.Name (ModuleName(..)) + import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Utils.Panic.Plain @@ -84,10 +95,11 @@ import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc +import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import Control.DeepSeq -import Foreign hiding (shiftL, shiftR) +import Foreign hiding (shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe @@ -102,7 +114,7 @@ import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Control.Monad ( when, (<$!>), unless, forM_ ) +import Control.Monad ( when, (<$!>), unless, forM_, void ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -181,6 +193,12 @@ ix <- readFastMutInt ix_r action $ BS.fromForeignPtr arr 0 ix +unsafeUnpackBinBuffer :: ByteString -> IO BinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt len + return (BinMem noUserData ix_r sz_r arr_r) --------------------------------------------------------------- -- Bin @@ -217,7 +235,7 @@ openBinMem :: Int -> IO BinHandle openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- mallocForeignPtrBytes size arr_r <- newIORef arr @@ -235,6 +253,14 @@ then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p +-- | SeekBin but without calling expandBin +seekBinNoExpand :: BinHandle -> Bin a -> IO () +seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then panic "seekBinNoExpand: seek out of range" + else writeFastMutInt ix_r p + writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode @@ -244,16 +270,27 @@ hClose h readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO BinHandle +readBinMem_ filesize h = do arr <- mallocForeignPtrBytes filesize count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize when (count /= filesize) $ error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h arr_r <- newIORef arr ix_r <- newFastMutInt 0 sz_r <- newFastMutInt filesize @@ -552,7 +589,9 @@ -- | Encode the argument in it's full length. This is different from many default -- binary instances which make no guarantee about the actual encoding and -- might do things use variable length encoding. -newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a } +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) instance Binary (FixedLengthEncoding Word8) where put_ h (FixedLengthEncoding x) = putByte h x @@ -777,7 +816,7 @@ * Start with a tag byte * 0 => Int64 (LEB128 encoded) - * 1 => Negative large interger + * 1 => Negative large integer * 2 => Positive large integer * Followed by the value: * Int64 is encoded as usual @@ -915,6 +954,45 @@ -- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B +-- by using a forward reference +forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBin bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBin bh + putAt bh pre_a a + seekBinNoExpand bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +forwardGet :: BinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBin bh + -- go read the forward value, then seek back + seekBinNoExpand bh p + r <- get_A + seekBinNoExpand bh p_a + pure r + +-- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () @@ -1021,8 +1099,14 @@ ud_put_fs = put_fs } -noUserData :: a -noUserData = undef "UserData" +noUserData :: UserData +noUserData = UserData + { ud_get_name = undef "get_name" + , ud_get_fs = undef "get_fs" + , ud_put_nonbinding_name = undef "put_nonbinding_name" + , ud_put_binding_name = undef "put_binding_name" + , ud_put_fs = undef "put_fs" + } undef :: String -> a undef s = panic ("Binary.UserData: no " ++ s) @@ -1050,6 +1134,58 @@ writeArray mut_arr i fs unsafeFreeze mut_arr +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + + +initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int) +initFSTable bh = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + -- BinHandle with FastString writing support + let ud = getUserData bh + let ud_fs = ud { ud_put_fs = putDictFastString bin_dict } + let bh_fs = setUserData bh ud_fs + + return (bh_fs,bin_dict,put_dict) + +putDictFastString :: FSTable -> BinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + --------------------------------------------------------- -- The Symbol Table --------------------------------------------------------- @@ -1075,13 +1211,13 @@ putBS bh bs = BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do put_ bh l - putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) getBS :: BinHandle -> IO ByteString getBS bh = do l <- get bh :: IO Int BS.create l $ \dest -> do - getPrim bh l (\src -> copyBytes dest src l) + getPrim bh l (\src -> BS.memcpy dest src l) instance Binary ByteString where put_ bh f = putBS bh f @@ -1103,6 +1239,10 @@ put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + -- instance Binary FunctionOrData where -- put_ bh IsFunction = putByte bh 0 -- put_ bh IsData = putByte bh 1 @@ -1279,18 +1419,23 @@ -- fs <- get bh -- return (StringLiteral st fs Nothing) -instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l +newtype BinLocated a = BinLocated { unBinLocated :: Located a } + +instance Binary a => Binary (BinLocated a) where + put_ bh (BinLocated (L l x)) = do + put_ bh $ BinSrcSpan l put_ bh x get bh = do - l <- get bh + l <- unBinSrcSpan <$> get bh x <- get bh - return (L l x) + return $ BinLocated (L l x) -instance Binary RealSrcSpan where - put_ bh ss = do +newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSpan where + put_ bh (BinSpan ss) = do put_ bh (srcSpanFile ss) put_ bh (srcSpanStartLine ss) put_ bh (srcSpanStartCol ss) @@ -1303,8 +1448,8 @@ sc <- get bh el <- get bh ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) instance Binary UnhelpfulSpanReason where put_ bh r = case r of @@ -1323,24 +1468,44 @@ 3 -> return UnhelpfulGenerated _ -> UnhelpfulOther <$> get bh -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss _sb) = do +newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSrcSpan where + put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do putByte bh 0 -- BufSpan doesn't ever get serialised because the positions depend -- on build location. - put_ bh ss + put_ bh $ BinSpan ss - put_ bh (UnhelpfulSpan s) = do + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of - 0 -> do ss <- get bh - return (RealSrcSpan ss Strict.Nothing) + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) _ -> do s <- get bh - return (UnhelpfulSpan s) + return $ BinSrcSpan (UnhelpfulSpan s) + + +{- +Note [Source Location Wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Source locations are banned from interface files, to +prevent filepaths affecting interface hashes. + +Unfortunately, we can't remove all binary instances, +as they're used to serialise .hie files, and we don't +want to break binary compatibility. + +To this end, the Bin[Src]Span newtypes wrappers were +introduced to prevent accidentally serialising a +source location as part of a larger structure. +-} -------------------------------------------------------------------------------- -- Instances for the containers package diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs --- a/compiler/GHC/Utils/BufHandle.hs +++ b/compiler/GHC/Utils/BufHandle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- @@ -24,7 +25,7 @@ bFlush, ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Data.FastString import GHC.Data.FastMutInt @@ -37,6 +38,10 @@ import Foreign.C.String import System.IO +-- for RULES +import GHC.Exts (unpackCString#, unpackNBytes#, Int(..)) +import GHC.Ptr (Ptr(..)) + -- ----------------------------------------------------------------------------- data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) @@ -61,6 +66,22 @@ bPutChar b c else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) writeFastMutInt r (i+1) + +-- Equivalent of the text/str, text/unpackNBytes#, text/[] rules +-- in GHC.Utils.Ppr. +{-# RULES "hdoc/str" + forall a h. bPutStr h (unpackCString# a) = bPutPtrString h (mkPtrString# a) + #-} +{-# RULES "hdoc/unpackNBytes#" + forall p n h. bPutStr h (unpackNBytes# p n) = bPutPtrString h (PtrString (Ptr p) (I# n)) + #-} +{-# RULES "hdoc/[]#" + forall h. bPutStr h [] = return () + #-} + +{-# NOINLINE [0] bPutStr #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested bPutStr :: BufHandle -> String -> IO () bPutStr (BufHandle buf r hdl) !str = do diff --git a/compiler/GHC/Utils/Constants.hs b/compiler/GHC/Utils/Constants.hs --- a/compiler/GHC/Utils/Constants.hs +++ b/compiler/GHC/Utils/Constants.hs @@ -8,7 +8,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic {- diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -25,14 +26,14 @@ errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, + pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, pprMessages, - pprLocMsgEnvelope, + pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, formatBulleted, -- ** Construction DiagOpts (..), diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, + emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, @@ -58,6 +59,7 @@ ghcExit, prettyPrintGhcErrors, traceCmd, + traceSystoolCommand, sortMsgBag ) where @@ -123,13 +125,13 @@ -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the -- 'DiagOpts. -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass -mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason +mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass +mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the --- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag +errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing -- -- Creating MsgEnvelope(s) @@ -139,12 +141,12 @@ :: Diagnostic e => Severity -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mk_msg_envelope severity locn print_unqual err +mk_msg_envelope severity locn name_ppr_ctx err = MsgEnvelope { errMsgSpan = locn - , errMsgContext = print_unqual + , errMsgContext = name_ppr_ctx , errMsgDiagnostic = err , errMsgSeverity = severity } @@ -156,22 +158,22 @@ :: Diagnostic e => DiagOpts -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkMsgEnvelope opts locn print_unqual err - = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err +mkMsgEnvelope opts locn name_ppr_ctx err + = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn name_ppr_ctx err -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. -- Precondition: the diagnostic is, in fact, an error. That is, -- @diagnosticReason msg == ErrorWithoutFlag@. mkErrorMsgEnvelope :: Diagnostic e => SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkErrorMsgEnvelope locn unqual msg = - assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg +mkErrorMsgEnvelope locn name_ppr_ctx msg = + assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx msg -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e @@ -227,20 +229,31 @@ msgs = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprMessages :: Diagnostic e => Messages e -> SDoc -pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages +pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc +pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages -pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] +pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s +-- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really +-- care about what the configuration is (for example, if the message is in a panic). +pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] + +pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) + +pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev - , errMsgContext = unqual }) + , errMsgContext = name_ppr_ctx }) = sdocWithContext $ \ctx -> - withErrStyle unqual $ - mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e) + withErrStyle name_ppr_ctx $ + mkLocMessage + (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) + s + (formatBulleted ctx $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList @@ -417,13 +430,13 @@ putMsg :: Logger -> SDoc -> IO () putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) -printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printInfoForUser logger print_unqual msg - = logInfo logger (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printInfoForUser logger name_ppr_ctx msg + = logInfo logger (withUserStyle name_ppr_ctx AllTheWay msg) -printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printOutputForUser logger print_unqual msg - = logOutput logger (withUserStyle print_unqual AllTheWay msg) +printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printOutputForUser logger name_ppr_ctx msg + = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () logInfo logger msg = logMsg logger MCInfo noSrcSpan msg @@ -459,6 +472,20 @@ loggerTraceFlush logger -- And run it! action `catchIO` handle_exn + + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceSystoolCommand :: Logger -> String -> IO a -> IO a +traceSystoolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) + {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Utils/Exception.hs b/compiler/GHC/Utils/Exception.hs --- a/compiler/GHC/Utils/Exception.hs +++ b/compiler/GHC/Utils/Exception.hs @@ -8,7 +8,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.IO (catchException) import Control.Exception as CE hiding (assert) diff --git a/compiler/GHC/Utils/Fingerprint.hs b/compiler/GHC/Utils/Fingerprint.hs --- a/compiler/GHC/Utils/Fingerprint.hs +++ b/compiler/GHC/Utils/Fingerprint.hs @@ -22,7 +22,7 @@ getFileHash ) where -import GHC.Prelude +import GHC.Prelude.Basic import Foreign import GHC.IO diff --git a/compiler/GHC/Utils/GlobalVars.hs b/compiler/GHC/Utils/GlobalVars.hs --- a/compiler/GHC/Utils/GlobalVars.hs +++ b/compiler/GHC/Utils/GlobalVars.hs @@ -22,7 +22,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Conc.Sync ( sharedCAF ) diff --git a/compiler/GHC/Utils/IO/Unsafe.hs b/compiler/GHC/Utils/IO/Unsafe.hs --- a/compiler/GHC/Utils/IO/Unsafe.hs +++ b/compiler/GHC/Utils/IO/Unsafe.hs @@ -9,7 +9,7 @@ ) where -import GHC.Prelude () +import GHC.Prelude.Basic () import GHC.Exts import GHC.IO (IO(..)) diff --git a/compiler/GHC/Utils/Json.hs b/compiler/GHC/Utils/Json.hs --- a/compiler/GHC/Utils/Json.hs +++ b/compiler/GHC/Utils/Json.hs @@ -14,6 +14,7 @@ JSBool :: Bool -> JsonDoc JSInt :: Int -> JsonDoc JSString :: String -> JsonDoc + -- ^ The 'String' is unescaped JSArray :: [JsonDoc] -> JsonDoc JSObject :: [(String, JsonDoc)] -> JsonDoc @@ -23,7 +24,7 @@ renderJSON d = case d of JSNull -> text "null" - JSBool b -> text $ if b then "true" else "false" + JSBool b -> if b then text "true" else text "false" JSInt n -> ppr n JSString s -> doubleQuotes $ text $ escapeJsonString s JSArray as -> brackets $ pprList renderJSON as @@ -57,7 +58,7 @@ json :: a -> JsonDoc instance ToJson String where - json = JSString . escapeJsonString + json = JSString instance ToJson Int where json = JSInt diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs --- a/compiler/GHC/Utils/Lexeme.hs +++ b/compiler/GHC/Utils/Lexeme.hs @@ -67,19 +67,17 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) +isLexConId cs = case unpackFS cs of -- Prefix type or data constructors + [] -> False -- e.g. "Foo", "[]", "(,)" + c:_ -> cs == fsLit "[]" || startsConId c -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) +isLexVarId cs = case unpackFS cs of -- Ordinary prefix identifiers + [] -> False -- e.g. "x", "_x" + c:_ -> startsVarId c -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) +isLexConSym cs = case unpackFS cs of -- Infix type or data constructors + [] -> False -- e.g. ":-:", ":", "->" + c:_ -> cs == fsLit "->" || startsConSym c isLexVarSym fs -- Infix identifiers e.g. "+" | fs == (fsLit "~R#") = True diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -9,7 +9,7 @@ -- hooks. The compiler itself uses hooks in multithreaded code (--make) and it -- is also probably used by ghc-api users (IDEs, etc.). -- --- In addition to hooks, the Logger suppors LogFlags: basically a subset of the +-- In addition to hooks, the Logger supports LogFlags: basically a subset of the -- command-line flags that control the logger behaviour at a higher level than -- hooks. -- @@ -88,19 +88,18 @@ import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import Data.IORef import System.Directory import System.FilePath ( takeDirectory, () ) -import qualified Data.Set as Set -import Data.Set (Set) -import Data.List (intercalate, stripPrefix) -import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.List (stripPrefix) import Data.Time import System.IO import Control.Monad import Control.Concurrent.MVar import System.IO.Unsafe import Debug.Trace (trace) +import GHC.Platform.Ways --------------------------------------------------------------- -- Log flags @@ -118,8 +117,10 @@ , log_dump_dir :: !(Maybe FilePath) -- ^ Dump directory , log_dump_prefix :: !FilePath -- ^ Normal dump path ("basename.") , log_dump_prefix_override :: !(Maybe FilePath) -- ^ Overriden dump path + , log_with_ways :: !Bool -- ^ Use different dump files names for different ways , log_enable_debug :: !Bool -- ^ Enable debug output , log_verbosity :: !Int -- ^ Verbosity level + , log_ways :: !(Maybe Ways) -- ^ Current ways (to name dump files) } -- | Default LogFlags @@ -135,13 +136,15 @@ , log_dump_dir = Nothing , log_dump_prefix = "" , log_dump_prefix_override = Nothing + , log_with_ways = True , log_enable_debug = False , log_verbosity = 0 + , log_ways = Nothing } -- | Test if a DumpFlag is enabled log_dopt :: DumpFlag -> LogFlags -> Bool -log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags +log_dopt = getDumpFlagFrom log_verbosity log_dump_flags -- | Enable a DumpFlag log_set_dopt :: DumpFlag -> LogFlags -> LogFlags @@ -198,10 +201,14 @@ | FormatASM -- ^ Assembly code | FormatC -- ^ C code/header | FormatLLVM -- ^ LLVM bytecode + | FormatJS -- ^ JavaScript code | FormatText -- ^ Unstructured dump deriving (Show,Eq) -type DumpCache = IORef (Set FilePath) +-- | A set of the dump files to which we have written thusfar. Each dump file +-- has a corresponding MVar to ensure that a dump file has at most one active +-- writer at a time, avoiding interleaved output. +type DumpCache = MVar (Map FilePath (MVar ())) data Logger = Logger { log_hook :: [LogAction -> LogAction] @@ -239,7 +246,7 @@ initLogger :: IO Logger initLogger = do - dumps <- newIORef Set.empty + dumps <- newMVar Map.empty return $ Logger { log_hook = [] , dump_hook = [] @@ -323,11 +330,11 @@ -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction -jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message +jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message jsonLogAction logflags msg_class srcSpan msg = defaultLogActionHPutStrDoc logflags True stdout - (withPprStyle (PprCode CStyle) (doc $$ text "")) + (withPprStyle PprCode (doc $$ text "")) where str = renderWithContext (log_default_user_context logflags) msg doc = renderJSON $ @@ -340,21 +347,21 @@ defaultLogAction logflags msg_class srcSpan msg | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg | otherwise = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ -> pure () -- suppress the message - MCDiagnostic sev rea -> printDiagnostics sev rea + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code -> printDiagnostics where printOut = defaultLogActionHPrintDoc logflags False stdout printErrs = defaultLogActionHPrintDoc logflags False stderr putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout -- Pretty print the warning flag, if any (#10752) - message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg + message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics severity reason = do + printDiagnostics = do hPutChar stderr '\n' caretDiagnostic <- if log_show_caret logflags @@ -362,35 +369,12 @@ else pure empty printErrs $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) - (message severity reason $+$ caretDiagnostic) + (message $+$ caretDiagnostic) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. - flagMsg :: Severity -> DiagnosticReason -> Maybe String - flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore" - flagMsg SevError WarningWithoutFlag = Just "-Werror" - flagMsg SevError (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return $ - "-W" ++ name ++ warnFlagGrp wflag ++ - ", -Werror=" ++ name - flagMsg SevError ErrorWithoutFlag = Nothing - flagMsg SevWarning WarningWithoutFlag = Nothing - flagMsg SevWarning (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return ("-W" ++ name ++ warnFlagGrp wflag) - flagMsg SevWarning ErrorWithoutFlag = - panic "SevWarning with ErrorWithoutFlag" - - warnFlagGrp flag - | log_show_warn_groups logflags = - case smallestWarningGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d @@ -428,7 +412,7 @@ -- | Write out a dump. -- -- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout (via the the LogAction parameter). +-- otherwise emit to stdout (via the LogAction parameter). -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines) @@ -462,16 +446,24 @@ -- file, otherwise 'Nothing'. withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () withDumpFileHandle dumps logflags flag action = do - let mFile = chooseDumpFile logflags flag + let dump_ways = log_ways logflags + let mFile = chooseDumpFile logflags dump_ways flag case mFile of Just fileName -> do - gd <- readIORef dumps - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef dumps (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do + lock <- modifyMVar dumps $ \gd -> + case Map.lookup fileName gd of + Nothing -> do + lock <- newMVar () + let gd' = Map.insert fileName lock gd + -- ensure that file exists so we can append to it + createDirectoryIfMissing True (takeDirectory fileName) + writeFile fileName "" + return (gd', lock) + Just lock -> do + return (gd, lock) + + let withLock k = withMVar lock $ \() -> k >> return () + withLock $ withFile fileName AppendMode $ \handle -> do -- We do not want the dump file to be affected by -- environment variables, but instead to always use -- UTF8. See: @@ -482,14 +474,20 @@ Nothing -> action Nothing -- | Choose where to put a dump file based on LogFlags and DumpFlag -chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile logflags flag +chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath +chooseDumpFile logflags ways flag | log_dump_to_file logflags || forced_to_file - = Just $ setDir (getPrefix ++ dump_suffix) + = Just $ setDir (getPrefix ++ way_infix ++ dump_suffix) | otherwise = Nothing where + way_infix = case ways of + _ | not (log_with_ways logflags) -> "" + Nothing -> "" + Just ws + | null ws || null (waysTag ws) -> "" + | otherwise -> waysTag ws ++ "." (forced_to_file, dump_suffix) = case flag of -- -dth-dec-file dumps expansions of TH -- splices into MODULE.th.hs even when @@ -565,29 +563,29 @@ -- | Dump if the given DumpFlag is set -- --- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument +-- Unlike 'putDumpFileMaybe', has a NamePprCtx argument putDumpFileMaybe' :: Logger - -> PrintUnqualified + -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -putDumpFileMaybe' logger printer flag hdr fmt doc +putDumpFileMaybe' logger name_ppr_ctx flag hdr fmt doc = when (logHasDumpFlag logger flag) $ - logDumpFile' logger printer flag hdr fmt doc + logDumpFile' logger name_ppr_ctx flag hdr fmt doc {-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities] -logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag +logDumpFile' :: Logger -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () {-# NOINLINE logDumpFile' #-} -- NOINLINE: Now we are past the conditional, into the "cold" path, -- don't inline, to reduce code size at the call site -- See Note [INLINE conditional tracing utilities] -logDumpFile' logger printer flag hdr fmt doc - = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc +logDumpFile' logger name_ppr_ctx flag hdr fmt doc + = logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr fmt doc -- | Ensure that a dump file is created even if it stays empty touchDumpFile :: Logger -> DumpFlag -> IO () diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -4,12 +4,9 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Highly random utility functions -- module GHC.Utils.Misc ( @@ -18,9 +15,7 @@ -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, - - zipWithLazy, zipWith3Lazy, + stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -29,7 +24,6 @@ mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, - mapAccumM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -45,6 +39,8 @@ chunkList, + holes, + changeLast, mapLastM, @@ -59,10 +55,8 @@ -- * Tuples fstOf3, sndOf3, thdOf3, - firstM, first3M, secondM, fst3, snd3, third3, uncurry3, - liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, @@ -72,8 +66,7 @@ sortWith, minWith, nubSort, ordNub, ordNubOn, -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, + isEqual, removeSpaces, (<&&>), (<||>), @@ -127,7 +120,7 @@ HasDebugCallStack, ) where -import GHC.Prelude +import GHC.Prelude.Basic hiding ( head, init, last, tail ) import GHC.Utils.Exception import GHC.Utils.Panic.Plain @@ -136,18 +129,20 @@ import Data.Data import qualified Data.List as List -import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List as Partial ( head ) +import Data.List.NonEmpty ( NonEmpty(..), last, nonEmpty ) +import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM, guard ) +import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath +import Data.Bifunctor ( first, second ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int @@ -159,9 +154,6 @@ import Data.Time -infixr 9 `thenCmp` - - {- ************************************************************************ * * @@ -203,21 +195,6 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) -secondM f (x, y) = (x,) <$> f y - {- ************************************************************************ * * @@ -251,10 +228,10 @@ DEBUGging on; hey, why not? -} -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual _ = zip @@ -281,25 +258,6 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) #endif --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal @@ -350,11 +308,11 @@ [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] +mapFst :: Functor f => (a->c) -> f(a,b) -> f(c,b) +mapSnd :: Functor f => (b->c) -> f(a,b) -> f(a,c) -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] +mapFst = fmap . first +mapSnd = fmap . second mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) @@ -529,6 +487,13 @@ chunkList _ [] = [] chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs +-- | Compute all the ways of removing a single element from a list. +-- +-- > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])] +holes :: [a] -> [(a, [a])] +holes [] = [] +holes (x:xs) = (x, xs) : mapSnd (x:) (holes xs) + -- | Replace the last element of a list with another element. changeLast :: [a] -> a -> [a] changeLast [] _ = panic "changeLast" @@ -536,20 +501,9 @@ changeLast (x:xs) x' = x : changeLast xs x' -- | Apply an effectful function to the last list element. --- Assumes a non-empty list (panics otherwise). -mapLastM :: Functor f => (a -> f a) -> [a] -> f [a] -mapLastM _ [] = panic "mapLastM: empty list" -mapLastM f [x] = (\x' -> [x']) <$> f x -mapLastM f (x:xs) = (x:) <$> mapLastM f xs - -mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b]) -mapAccumM f = go - where - go acc [] = pure (acc,[]) - go acc (x:xs) = do - (acc',y) <- f acc x - (acc'',ys) <- go acc' xs - pure (acc'', y:ys) +mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) +mapLastM f (x:|[]) = NE.singleton <$> f x +mapLastM f (x0:|x1:xs) = (x0 NE.<|) <$> mapLastM f (x1:|xs) whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () @@ -613,7 +567,7 @@ minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = assert (not (null xs) ) - head (sortWith get_key xs) + Partial.head (sortWith get_key xs) nubSort :: Ord a => [a] -> [a] nubSort = Set.toAscList . Set.fromList @@ -764,16 +718,14 @@ | p x = go yes (x : rev_yes) rev_no xs | otherwise = go xs [] (x : rev_yes ++ rev_no) xs --- | Get the last two elements in a list. Partial! +-- | Get the last two elements in a list. {-# INLINE last2 #-} -last2 :: [a] -> (a,a) -last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) - where - partialError = panic "last2 - list length less than two" +last2 :: [a] -> Maybe (a,a) +last2 = uncurry (liftA2 (,)) . List.foldl' (\(_,x2) x -> (x2, Just x)) (Nothing, Nothing) lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing -lastMaybe xs = Just $ last xs +lastMaybe (x:xs) = Just $ last (x:|xs) -- | @onJust x m f@ applies f to the value inside the Just or returns the default. onJust :: b -> Maybe a -> (a->b) -> b @@ -787,17 +739,12 @@ -- If you are guaranteed to use both, this will -- be more efficient. snocView :: [a] -> Maybe ([a],a) -snocView [] = Nothing -snocView xs - | (xs,x) <- go xs - = Just (xs,x) +snocView = fmap go . nonEmpty where - go :: [a] -> ([a],a) - go [x] = ([],x) - go (x:xs) - | !(xs',x') <- go xs - = (x:xs', x') - go [] = error "impossible" + go :: NonEmpty a -> ([a],a) + go (x:|xs) = case nonEmpty xs of + Nothing -> ([],x) + Just xs -> case go xs of !(xs', x') -> (x:xs', x') split :: Char -> String -> [String] split c s = case rest of @@ -825,30 +772,6 @@ isEqual EQ = True isEqual LT = False -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - removeSpaces :: String -> String removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace @@ -971,10 +894,10 @@ -- | Search for possible matches to the users input in the given list, -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] -fuzzyLookup user_entered possibilites +fuzzyLookup user_entered possibilities = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd) [ (poss_val, sort_key) - | (poss_str, poss_val) <- possibilites + | (poss_str, poss_val) <- possibilities , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered , distance <= fuzzy_threshold , let sort_key = (distance, length poss_str, poss_str) @@ -1007,7 +930,7 @@ -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +unzipWith = fmap . uncurry seqList :: [a] -> b -> b seqList [] b = b @@ -1340,9 +1263,9 @@ -- string is returned in the first component (and the second one is just -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) -splitLongestPrefix str pred - | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) +splitLongestPrefix str pred = case r_pre of + [] -> (str, []) + _:r_pre' -> (reverse r_pre', reverse r_suf) -- 'tail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred (reverse str) diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MonadComprehensions #-} + -- | Utilities related to Monad and Applicative classes -- Mostly for backwards compatibility. @@ -11,16 +13,14 @@ , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM - , liftFstM, liftSndM , mapSndM , concatMapM , mapMaybeM - , fmapMaybeM, fmapEitherM , anyM, allM, orM , foldlM, foldlM_, foldrM - , maybeMapM , whenM, unlessM , filterOutM + , partitionM ) where ------------------------------------------------------------------------------- @@ -29,12 +29,14 @@ import GHC.Prelude -import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class +import Control.Monad.Trans.State.Strict (StateT (..)) import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Tuple (swap) ------------------------------------------------------------------------------- -- Common functions @@ -142,81 +144,80 @@ -- variant and use it where appropriate. -- | Monadic version of mapAccumL -mapAccumLM :: Monad m +mapAccumLM :: (Monad m, Traversable t) => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM f s xs = - go s xs + -> t x -- ^ inputs + -> m (acc, t y) -- ^ final state, outputs +{-# INLINE [1] mapAccumLM #-} +-- INLINE pragma. mapAccumLM is called in inner loops. Like 'map', +-- we inline it so that we can take advantage of knowing 'f'. +-- This makes a few percent difference (in compiler allocations) +-- when compiling perf/compiler/T9675 +mapAccumLM f s = fmap swap . flip runStateT s . traverse f' where + f' = StateT . (fmap . fmap) swap . flip f +{-# RULES "mapAccumLM/List" mapAccumLM = mapAccumLM_List #-} +{-# RULES "mapAccumLM/NonEmpty" mapAccumLM = mapAccumLM_NonEmpty #-} + +mapAccumLM_List + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> [x] -> m (acc, [y]) +{-# INLINE mapAccumLM_List #-} +mapAccumLM_List f s = go s + where go s (x:xs) = do (s1, x') <- f s x (s2, xs') <- go s1 xs return (s2, x' : xs') go s [] = return (s, []) --- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM f xs = go xs - where - go [] = return [] - go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) } - -liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r) -liftFstM f thing = do { (a,r) <- thing; return (f a, r) } +mapAccumLM_NonEmpty + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> NonEmpty x -> m (acc, NonEmpty y) +{-# INLINE mapAccumLM_NonEmpty #-} +mapAccumLM_NonEmpty f s (x:|xs) = + [(s2, x':|xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs] -liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b) -liftSndM f thing = do { (r,a) <- thing; return (r, f a) } +-- | Monadic version of mapSnd +mapSndM :: (Applicative m, Traversable f) => (b -> m c) -> f (a,b) -> m (f (a,c)) +mapSndM = traverse . traverse -- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM :: (Monad m, Traversable f) => (a -> m [b]) -> f a -> m [b] concatMapM f xs = liftM concat (mapM f xs) +{-# INLINE concatMapM #-} +-- It's better to inline to inline this than to specialise +-- concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +-- Inlining cuts compiler allocation by around 1% -- | Applicative version of mapMaybe mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = foldr g (pure []) where g a = liftA2 (maybe id (:)) (f a) --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - -- | Monadic version of 'any', aborts the computation at the first @True@ value -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM f xs = go xs - where - go [] = return False - go (x:xs) = do b <- f x - if b then return True - else go xs +anyM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +anyM f = foldr (orM . f) (pure False) -- | Monad version of 'all', aborts the computation at the first @False@ value -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM f bs = go bs - where - go [] = return True - go (b:bs) = (f b) >>= (\bv -> if bv then go bs else return False) +allM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +allM f = foldr (andM . f) (pure True) -- | Monadic version of or orM :: Monad m => m Bool -> m Bool -> m Bool orM m1 m2 = m1 >>= \x -> if x then return True else m2 +-- | Monadic version of and +andM :: Monad m => m Bool -> m Bool -> m Bool +andM m1 m2 = m1 >>= \x -> if x then m2 else return False + -- | Monadic version of foldl that discards its result foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_ --- | Monadic version of fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () whenM mb thing = do { b <- mb @@ -232,6 +233,14 @@ filterOutM p = foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) +-- | Monadic version of @partition@ +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those @@ -342,7 +351,7 @@ patterns.) That's the advantage of the pattern-synonym approach, but it is more elaborate. -The pattern synonym approach is due to Sebastian Graaf (#18238) +The pattern synonym approach is due to Sebastian Graf (#18238) Do note that for monads for multiple arguments more than one oneShot function might be required. For example in FCode we use: @@ -355,8 +364,8 @@ where FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) -INLINE pragmas and (>>) -~~~~~~~~~~~~~~~~~~~~~~~ +Note [INLINE pragmas and (>>)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A nasty gotcha is described in #20008. In brief, be careful if you get (>>) via its default method: @@ -422,7 +431,7 @@ The magic `inline` function does two things * It prevents eta reduction. If we wrote just multiShotIO (IO m) = IO (\s -> m s) - the lamda would eta-reduce to 'm' and all would be lost. + the lambda would eta-reduce to 'm' and all would be lost. * It helps ensure that 'm' really does inline. diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} @@ -5,6 +6,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} {- (c) The University of Glasgow 2006-2012 @@ -21,27 +24,28 @@ -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), + IsOutput(..), IsLine(..), IsDoc(..), + HLine, HDoc, + -- * Pretty printing combinators SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, + spaceIfSingleQuote, + isEmpty, nest, + ptext, int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, forAllLit, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + ($+$), + cat, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, speakNth, speakN, speakNOf, plural, singular, @@ -78,44 +82,54 @@ pprFastFilePath, pprFilePathString, + pprModuleName, + -- * Controlling the style in which output is printed BindingSite(..), - PprStyle(..), LabelStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + PprStyle(..), NamePprCtx(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, + PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, + PromotionTickContext(..), reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, + alwaysPrintPromTick, QualifyName(..), queryQual, sdocOption, updSDocContext, - SDocContext (..), sdocWithContext, defaultSDocContext, + SDocContext (..), sdocWithContext, + defaultSDocContext, traceSDocContext, getPprStyle, withPprStyle, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, dumpStyle, asmStyle, - qualName, qualModule, qualPackage, + codeStyle, userStyle, dumpStyle, + qualName, qualModule, qualPackage, promTick, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), withUserStyle, withErrStyle, ifPprDebug, whenPprDebug, getPprDebug, + bPutHDoc ) where -import GHC.Prelude +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import GHC.Prelude.Basic + import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) -import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) -import GHC.Utils.BufHandle (BufHandle) +import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr ( Doc, Mode(..) ) import GHC.Serialized import GHC.LanguageExtensions (Extension) +import GHC.Utils.GlobalVars( unsafeHasPprDebug ) +import GHC.Utils.Misc (lastMaybe) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -138,6 +152,7 @@ import qualified Data.List.NonEmpty as NEL import Data.Time import Data.Time.Format.ISO8601 +import Data.Void import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -153,32 +168,19 @@ -} data PprStyle - = PprUser PrintUnqualified Depth Coloured + = PprUser NamePprCtx Depth Coloured -- Pretty-print in a way that will make sense to the -- ordinary user; must be very close to Haskell -- syntax, etc. -- Assumes printing tidied code: non-system names are -- printed without uniques. - | PprDump PrintUnqualified + | PprDump NamePprCtx -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. - | PprCode !LabelStyle -- ^ Print code; either C or assembler - --- | Style of label pretty-printing. --- --- When we produce C sources or headers, we have to take into account that C --- compilers transform C labels when they convert them into symbols. For --- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for --- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style --- or Asm style. --- -data LabelStyle - = CStyle -- ^ C label style (used by C and LLVM backends) - | AsmStyle -- ^ Asm label style (used by NCG backend) - deriving (Eq,Ord,Show) + | PprCode -- ^ Print code; either C or assembler data Depth = AllTheWay @@ -196,10 +198,11 @@ -- original names back to something the user understands. This is the -- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { +data NamePprCtx = QueryQualify { queryQualifyName :: QueryQualifyName, queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage + queryQualifyPackage :: QueryQualifyPackage, + queryPromotionTick :: QueryPromotionTick } -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify @@ -214,6 +217,31 @@ -- the component id to disambiguate it. type QueryQualifyPackage = Unit -> Bool +-- | Given a promoted data constructor, +-- decide whether to print a tick to disambiguate the namespace. +type QueryPromotionTick = PromotedItem -> Bool + +-- | Flags that affect whether a promotion tick is printed. +data PromotionTickContext = + PromTickCtx { + ptcListTuplePuns :: !Bool, + ptcPrintRedundantPromTicks :: !Bool + } + +data PromotedItem = + PromotedItemListSyntax IsEmptyOrSingleton -- '[x] + | PromotedItemTupleSyntax -- '(x, y) + | PromotedItemDataCon OccName -- 'MkT + +newtype IsEmptyOrSingleton = IsEmptyOrSingleton Bool + +isListEmptyOrSingleton :: [a] -> IsEmptyOrSingleton +isListEmptyOrSingleton xs = + IsEmptyOrSingleton $ case xs of + [] -> True + [_] -> True + _ -> False + -- See Note [Printing original names] in GHC.Types.Name.Ppr data QualifyName -- Given P:M.T = NameUnqual -- It's in scope unqualified as "T" @@ -255,17 +283,23 @@ neverQualifyPackages :: QueryQualifyPackage neverQualifyPackages _ = False -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +alwaysPrintPromTick :: QueryPromotionTick +alwaysPrintPromTick _ = True + +reallyAlwaysQualify, alwaysQualify, neverQualify :: NamePprCtx reallyAlwaysQualify = QueryQualify reallyAlwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick alwaysQualify = QueryQualify alwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick neverQualify = QueryQualify neverQualifyNames neverQualifyModules neverQualifyPackages + alwaysPrintPromTick defaultUserStyle :: PprStyle defaultUserStyle = mkUserStyle neverQualify AllTheWay @@ -274,31 +308,31 @@ -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle = PprDump neverQualify -mkDumpStyle :: PrintUnqualified -> PprStyle -mkDumpStyle print_unqual = PprDump print_unqual +mkDumpStyle :: NamePprCtx -> PprStyle +mkDumpStyle name_ppr_ctx = PprDump name_ppr_ctx --- | Default style for error messages, when we don't know PrintUnqualified +-- | Default style for error messages, when we don't know NamePprCtx -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs defaultErrStyle :: PprStyle defaultErrStyle = mkErrStyle neverQualify -- | Style for printing error messages -mkErrStyle :: PrintUnqualified -> PprStyle -mkErrStyle unqual = mkUserStyle unqual DefaultDepth +mkErrStyle :: NamePprCtx -> PprStyle +mkErrStyle name_ppr_ctx = mkUserStyle name_ppr_ctx DefaultDepth cmdlineParserStyle :: PprStyle cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay -mkUserStyle :: PrintUnqualified -> Depth -> PprStyle -mkUserStyle unqual depth = PprUser unqual depth Uncoloured +mkUserStyle :: NamePprCtx -> Depth -> PprStyle +mkUserStyle name_ppr_ctx depth = PprUser name_ppr_ctx depth Uncoloured -withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc -withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc +withUserStyle :: NamePprCtx -> Depth -> SDoc -> SDoc +withUserStyle name_ppr_ctx depth doc = withPprStyle (PprUser name_ppr_ctx depth Uncoloured) doc -withErrStyle :: PrintUnqualified -> SDoc -> SDoc -withErrStyle unqual doc = - withPprStyle (mkErrStyle unqual) doc +withErrStyle :: NamePprCtx -> SDoc -> SDoc +withErrStyle name_ppr_ctx doc = + withPprStyle (mkErrStyle name_ppr_ctx) doc setStyleColoured :: Bool -> PprStyle -> PprStyle setStyleColoured col style = @@ -358,7 +392,7 @@ , sdocLineLength :: !Int , sdocCanUseUnicode :: !Bool -- ^ True if Unicode encoding is supported - -- and not disable by GHC_NO_UNICODE environment variable + -- and not disabled by GHC_NO_UNICODE environment variable , sdocHexWordLiterals :: !Bool , sdocPprDebug :: !Bool , sdocPrintUnicodeSyntax :: !Bool @@ -386,7 +420,7 @@ , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool - , sdocImpredicativeTypes :: !Bool + , sdocListTuplePuns :: !Bool , sdocPrintTypeAbbreviations :: !Bool , sdocUnitIdForUser :: !(FastString -> SDoc) -- ^ Used to map UnitIds to more friendly "package-version:component" @@ -446,12 +480,24 @@ , sdocSuppressStgReps = True , sdocErrorSpans = False , sdocStarIsType = False - , sdocImpredicativeTypes = False , sdocLinearTypes = False + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } +traceSDocContext :: SDocContext +-- Used for pprTrace, when we want to see lots of info +traceSDocContext = defaultSDocContext + { sdocPprDebug = unsafeHasPprDebug + , sdocPrintTypecheckerElaboration = True + , sdocPrintExplicitKinds = True + , sdocPrintExplicitCoercions = True + , sdocPrintExplicitRuntimeReps = True + , sdocPrintExplicitForalls = True + , sdocPrintEqualityRelations = True + } + withPprStyle :: PprStyle -> SDoc -> SDoc {-# INLINE CONLIKE withPprStyle #-} withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} @@ -527,18 +573,20 @@ qualPackage (PprDump q) m = queryQualifyPackage q m qualPackage _other _m = True -queryQual :: PprStyle -> PrintUnqualified +promTick :: PprStyle -> QueryPromotionTick +promTick (PprUser q _ _) occ = queryPromotionTick q occ +promTick (PprDump q) occ = queryPromotionTick q occ +promTick _ _ = True + +queryQual :: PprStyle -> NamePprCtx queryQual s = QueryQualify (qualName s) (qualModule s) (qualPackage s) + (promTick s) codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False - -asmStyle :: PprStyle -> Bool -asmStyle (PprCode AsmStyle) = True -asmStyle _other = False +codeStyle PprCode = True +codeStyle _ = False dumpStyle :: PprStyle -> Bool dumpStyle (PprDump {}) = True @@ -549,17 +597,17 @@ userStyle _other = False -- | Indicate if -dppr-debug mode is enabled -getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug :: IsOutput doc => (Bool -> doc) -> doc {-# INLINE CONLIKE getPprDebug #-} -getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) +getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx) -- | Says what to do with and without -dppr-debug -ifPprDebug :: SDoc -> SDoc -> SDoc +ifPprDebug :: IsOutput doc => doc -> doc -> doc {-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no -- | Says what to do with -dppr-debug; without, return empty -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style {-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty @@ -586,9 +634,9 @@ bufLeftRenderSDoc ctx bufHandle doc = Pretty.bufLeftRender bufHandle (runSDoc doc ctx) -pprCode :: LabelStyle -> SDoc -> SDoc +pprCode :: SDoc -> SDoc {-# INLINE CONLIKE pprCode #-} -pprCode cs d = withPprStyle (PprCode cs) d +pprCode d = withPprStyle PprCode d renderWithContext :: SDocContext -> SDoc -> String renderWithContext ctx sdoc @@ -626,43 +674,26 @@ docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -{-# INLINE CONLIKE empty #-} -empty = docToSDoc $ Pretty.empty -{-# INLINE CONLIKE char #-} -char c = docToSDoc $ Pretty.char c - -{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire -text s = docToSDoc $ Pretty.text s +ptext :: PtrString -> SDoc +int :: IsLine doc => Int -> doc +integer :: IsLine doc => Integer -> doc +word :: Integer -> SDoc +float :: IsLine doc => Float -> doc +double :: IsLine doc => Double -> doc +rational :: Rational -> SDoc -{-# INLINE CONLIKE ftext #-} -ftext s = docToSDoc $ Pretty.ftext s {-# INLINE CONLIKE ptext #-} ptext s = docToSDoc $ Pretty.ptext s -{-# INLINE CONLIKE ztext #-} -ztext s = docToSDoc $ Pretty.ztext s {-# INLINE CONLIKE int #-} -int n = docToSDoc $ Pretty.int n +int n = text $ show n {-# INLINE CONLIKE integer #-} -integer n = docToSDoc $ Pretty.integer n +integer n = text $ show n {-# INLINE CONLIKE float #-} -float n = docToSDoc $ Pretty.float n +float n = text $ show n {-# INLINE CONLIKE double #-} -double n = docToSDoc $ Pretty.double n +double n = text $ show n {-# INLINE CONLIKE rational #-} -rational n = docToSDoc $ Pretty.rational n +rational n = text $ show n -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr {-# INLINE CONLIKE word #-} word n = sdocOption sdocHexWordLiterals $ \case @@ -674,19 +705,19 @@ doublePrec :: Int -> Double -> SDoc doublePrec p n = text (showFFloat (Just p) n "") -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc +quotes, quote :: SDoc -> SDoc +parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc {-# INLINE CONLIKE parens #-} -parens d = SDoc $ Pretty.parens . runSDoc d +parens d = char '(' <> d <> char ')' {-# INLINE CONLIKE braces #-} -braces d = SDoc $ Pretty.braces . runSDoc d +braces d = char '{' <> d <> char '}' {-# INLINE CONLIKE brackets #-} -brackets d = SDoc $ Pretty.brackets . runSDoc d +brackets d = char '[' <> d <> char ']' {-# INLINE CONLIKE quote #-} quote d = SDoc $ Pretty.quote . runSDoc d {-# INLINE CONLIKE doubleQuotes #-} -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +doubleQuotes d = char '"' <> d <> char '"' {-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>' @@ -705,42 +736,40 @@ in case str of [] -> Pretty.quotes pp_d '\'' : _ -> pp_d - _ | '\'' <- last str -> pp_d + _ | Just '\'' <- lastMaybe str -> pp_d | otherwise -> Pretty.quotes pp_d -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, + larrowtt, lambda :: SDoc blankLine = docToSDoc Pretty.emptyText -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +dcolon = unicodeSyntax (char '∷') (text "::") +arrow = unicodeSyntax (char '→') (text "->") +lollipop = unicodeSyntax (char '⊸') (text "%1 ->") +larrow = unicodeSyntax (char '←') (text "<-") +darrow = unicodeSyntax (char '⇒') (text "=>") +arrowt = unicodeSyntax (char '⤚') (text ">-") +larrowt = unicodeSyntax (char '⤙') (text "-<") +arrowtt = unicodeSyntax (char '⤜') (text ">>-") +larrowtt = unicodeSyntax (char '⤛') (text "-<<") lambda = unicodeSyntax (char 'λ') (char '\\') -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space + +semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc +semi = char ';' +comma = char ',' +colon = char ':' +equals = char '=' +space = char ' ' underscore = char '_' dot = char '.' vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace - -mulArrow :: SDoc -> SDoc -mulArrow d = text "%" <> d <+> arrow - +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") @@ -763,59 +792,26 @@ nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically {-# INLINE CONLIKE nest #-} nest n d = SDoc $ Pretty.nest n . runSDoc d -{-# INLINE CONLIKE (<>) #-} -(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE (<+>) #-} -(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE ($$) #-} -($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) {-# INLINE CONLIKE ($+$) #-} ($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits cat :: [SDoc] -> SDoc --- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc -- ^ A paragraph-fill combinator. It's much like sep, only it -- keeps fitting things on one line until it can't fit any more. fcat :: [SDoc] -> SDoc --- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal composition rather than '<+>' -- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc -- later applied to the same SDocContext. It helps the worker/wrapper -- transformation extracting only the required fields from the SDocContext. -{-# INLINE CONLIKE hcat #-} -hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE hsep #-} -hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE vcat #-} -vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE sep #-} -sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE cat #-} cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE fsep #-} -fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE fcat #-} fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] @@ -833,16 +829,17 @@ hangNotEmpty d1 n d2 = SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list +punctuate :: IsLine doc + => doc -- ^ The punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es -ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc ppWhen False _ = empty @@ -858,10 +855,9 @@ False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppUnlessOption f doc = sdocOption f $ \case - True -> empty - False -> doc +ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc +ppUnlessOption f doc = docWithContext $ + \ctx -> if f ctx then empty else doc -- | Apply the given colour\/style for the argument. -- @@ -888,8 +884,8 @@ class Outputable a where ppr :: a -> SDoc -instance Outputable Char where - ppr c = text [c] +-- There's no Outputable for Char; it's too easy to use Outputable +-- on String and have ppr "hello" rendered as "h,e,l,l,o". instance Outputable Bool where ppr True = text "True" @@ -946,16 +942,16 @@ ppr = text . formatShow iso8601Format instance (Outputable a) => Outputable [a] where - ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + ppr xs = brackets (pprWithCommas ppr xs) instance (Outputable a) => Outputable (NonEmpty a) where ppr = ppr . NEL.toList instance (Outputable a) => Outputable (Set a) where - ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + ppr s = braces (pprWithCommas ppr (Set.toList s)) instance Outputable IntSet.IntSet where - ppr s = braces (fsep (punctuate comma (map ppr (IntSet.toList s)))) + ppr s = braces (pprWithCommas ppr (IntSet.toList s)) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) @@ -1039,6 +1035,18 @@ instance Outputable Extension where ppr = text . show +instance Outputable ModuleName where + ppr = pprModuleName + +pprModuleName :: IsLine doc => ModuleName -> doc +pprModuleName (ModuleName nm) = + docWithContext $ \ctx -> + if codeStyle (sdocStyle ctx) + then ztext (zEncodeFS nm) + else ftext nm +{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} +{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] + ----------------------------------------------------------------------- -- The @OutputableP@ class ----------------------------------------------------------------------- @@ -1176,6 +1184,8 @@ instance (OutputableP env a) => OutputableP env (Set a) where pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s)))) +instance OutputableP env Void where + pdoc _ = \ case {- ************************************************************************ @@ -1256,14 +1266,14 @@ primIntSuffix = char '#' primDoubleSuffix = text "##" primWordSuffix = text "##" -primInt8Suffix = text "#8" -primWord8Suffix = text "##8" -primInt16Suffix = text "#16" -primWord16Suffix = text "##16" -primInt32Suffix = text "#32" -primWord32Suffix = text "##32" -primInt64Suffix = text "#64" -primWord64Suffix = text "##64" +primInt8Suffix = text "#Int8" +primWord8Suffix = text "#Word8" +primInt16Suffix = text "#Int16" +primWord16Suffix = text "#Word16" +primInt32Suffix = text "#Int32" +primWord32Suffix = text "#Word32" +primInt64Suffix = text "#Int64" +primWord64Suffix = text "#Word64" -- | Special combinator for showing unboxed literals. pprPrimChar :: Char -> SDoc @@ -1305,12 +1315,14 @@ -- | Normalise, escape and render a string representing a path -- -- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc +pprFilePathString :: IsLine doc => FilePath -> doc pprFilePathString path = doubleQuotes $ text (escape (normalise path)) where escape [] = [] escape ('\\':xs) = '\\':'\\':escape xs escape (x:xs) = x:escape xs +{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] {- ************************************************************************ @@ -1332,6 +1344,16 @@ -- bar-separated and finally packed into a paragraph. pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) +-- Prefix the document with a space if it starts with a single quote. +-- See Note [Printing promoted type constructors] in GHC.Iface.Type +spaceIfSingleQuote :: SDoc -> SDoc +spaceIfSingleQuote (SDoc m) = + SDoc $ \ctx -> + let (mHead, d) = Pretty.docHead (m ctx) + in if mHead == Just '\'' + then Pretty.space Pretty.<> d + else d + -- | Returns the separated concatenation of the pretty printed things. interppSP :: Outputable a => [a] -> SDoc interppSP xs = sep (map ppr xs) @@ -1489,3 +1511,352 @@ hasOrHave :: [a] -> SDoc hasOrHave [_] = text "has" hasOrHave _ = text "have" + +{- Note [SDoc versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SDoc type is used pervasively throughout the compiler to represent pretty- +printable output. Almost all text written by GHC, from the Haskell types and +expressions included in error messages to debug dumps, is assembled using SDoc. +SDoc is nice because it handles multiline layout in a semi-automatic fashion, +enabling printed expressions to wrap to fit a given line width while correctly +indenting the following lines to preserve alignment. + +SDoc’s niceties necessarily have some performance cost, but this is normally +okay, as printing output is rarely a performance bottleneck. However, one +notable exception to this is code generation: GHC must sometimes write +megabytes’ worth of generated assembly when compiling a single module, in which +case the overhead of SDoc has a significant cost (see #21853 for some numbers). +Moreover, generated assembly does not have the complex layout requirements of +pretty-printed Haskell code, so using SDoc does not buy us much, anyway. + +Nevertheless, we do still want to be able to share some logic between writing +assembly and pretty-printing. For example, the logic for printing basic block +labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single +implementation that can be used both when generating code and when generating +Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc +interface, but it is implemented in a far more efficient way, writing directly +to a `Handle` (via a `BufHandle`) without building any intermediate structures. +We can then use typeclasses to parameterize functions like `pprCLabel` over the +printing implementation. + +One might imagine this would result in one IsDoc typeclass, and two instances, +one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc, +as described in Note [HLine versus HDoc], and this gives rise to a small +typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc; +see Note [The outputable class hierarchy] for details. + +Note [HLine versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], HDoc does not support any of the layout +niceties of SDoc for efficiency. However, this presents a small problem if we +want to be compatible with the SDoc API, as expressions like + + text "foo" <+> (text "bar" $$ text "baz") + +are expected to produce + + foo bar + baz + +which requires tracking line widths to know how far to indent the second line. +We can’t throw out vertical composition altogether, as we need to be able to +construct multiline HDocs, but we *can* restrict vertical composition to +concatenating whole lines at a time, as this is all that is necessary to +generate assembly in the code generator. + +To implement this restriction, we provide two distinct types: HLine and HDoc. +As their names suggests, an HLine represents a single line of output, while an +HDoc represents a multiline document. Atoms formed from `char` and `text` begin +their lives as HLines, which can be horizontally (but not vertically) composed: + + char :: Char -> HLine + text :: String -> HLine + (<+>) :: HLine -> HLine -> HLine + +Once a line has been fully assembled, it can be “locked up” into a single-line +HDoc via `line`, and HDocs can be vertically (but not horizontally) composed: + + line :: HLine -> HDoc + ($$) :: HLine -> HLine -> HLine + +Note that, at runtime, HLine and HDoc use exactly the same representation. This +distinction only exists in the type system to rule out the cases we don’t want +to have to handle. + +Note [The outputable class hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], we want to be able to parameterize over +the choice of printing implementation when implementing common bits of printing +logic. However, as described in Note [HLine versus HDoc], we also want to +distinguish code that does single-line printing from code that does multi-line +printing. Therefore, code that is parameterized over the choice of printer must +respect this single- versus multi-line distinction. This naturally leads to two +typeclasses: + + class IsLine doc where + char :: Char -> doc + text :: String -> doc + (<>) :: doc -> doc -> doc + ... + + class IsLine (Line doc) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + ($$) :: doc -> doc -> doc + ... + +These classes support the following instances: + + instance IsLine SDoc + instance IsLine SDoc where + type Line SDoc = SDoc + + instance IsLine HLine + instance IsDoc HDoc where + type Line HDoc = HLine + +However, we run into a new problem: we provide many useful combinators on docs +that don’t care at all about the single-/multi-line distinction. For example, +ppWhen and ppUnless provide conditional logic, and docWithContext provides +access to the ambient SDocContext. Given the above classes, we would need two +variants of each of these combinators: + + ppWhenL :: IsLine doc => Bool -> doc -> doc + ppWhenL c d = if c then d else emptyL + + ppWhenD :: IsDoc doc => Bool -> doc -> doc + ppWhenD c d = if c then d else emptyD + +This is a needlessly annoying distinction, so we introduce a common superclass, +IsOutput, that allows these combinators to be generic over both variants: + + class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + + class IsOutput doc => IsLine doc + class (IsOutput doc, IsLine (Line doc)) => IsDoc doc + +In practice, IsOutput isn’t used explicitly very often, but it makes code that +uses the combinators derived from it significantly less noisy. + +Note [SPECIALIZE to HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes are useful to share printing logic between code +that uses SDoc and code that uses HDoc, but we must take some care when doing +so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses +it to eliminate unnecessary indirection, but the HDoc primitives must be inlined +before these opportunities can be exposed. Therefore, we want to explicitly +request that GHC generate HDoc (or HLine) specializations of any polymorphic +printing functions used by the code generator. + +In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize +pragma just to the entry point pprNatCmmDecl, to avoid cluttering +the entire module. Because specialization is transitive, this makes sure +that other functions in that module are specialized too. + +Note [dualLine and dualDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes provide the dualLine and dualDoc methods, +respectively, which have the following types: + + dualLine :: IsLine doc => SDoc -> HLine -> doc + dualDoc :: IsDoc doc => SDoc -> HDoc -> doc + +These are effectively a form of type-`case`, selecting between each of their two +arguments depending on the type they are instantiated at. They serve as a +“nuclear option” for code that is, for some reason or another, unreasonably +difficult to make completely equivalent under both printer implementations. + +These operations should generally be avoided, as they can result in surprising +changes in behavior when the printer implementation is changed. However, in +certain cases, the alternative is even worse. For example, we use dualLine in +the implementation of pprUnitId, as the hack we use for printing unit ids +(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine +and is not necessary for code paths that use it, anyway. + +Use these operations wisely. -} + +-- | Represents a single line of output that can be efficiently printed directly +-- to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () } + +-- | Represents a (possibly empty) sequence of lines that can be efficiently +-- printed directly to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () } + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine +pattern HLine f <- HLine' f + where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HLine #-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc +pattern HDoc f <- HDoc' f + where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HDoc #-} + +bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () +bPutHDoc h ctx (HDoc f) = f ctx h + +-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', +-- as well as access to the shared 'SDocContext'. +-- +-- See Note [The outputable class hierarchy] for more details. +class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + +-- | A class of types that represent a single logical line of text, with support +-- for horizontal composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class IsOutput doc => IsLine doc where + char :: Char -> doc + text :: String -> doc + ftext :: FastString -> doc + ztext :: FastZString -> doc + + -- | Join two @doc@s together horizontally without a gap. + (<>) :: doc -> doc -> doc + -- | Join two @doc@s together horizontally with a gap between them. + (<+>) :: doc -> doc -> doc + -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits. + sep :: [doc] -> doc + -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting + -- things on one line until it can't fit any more. + fsep :: [doc] -> doc + + -- | Concatenate @doc@s horizontally without gaps. + hcat :: [doc] -> doc + hcat docs = foldr (<>) empty docs + {-# INLINE CONLIKE hcat #-} + + -- | Concatenate @doc@s horizontally with a space between each one. + hsep :: [doc] -> doc + hsep docs = foldr (<+>) empty docs + {-# INLINE CONLIKE hsep #-} + + -- | Prints as either the given 'SDoc' or the given 'HLine', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualLine :: SDoc -> HLine -> doc + + +-- | A class of types that represent a multiline document, with support for +-- vertical composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + + -- | Join two @doc@s together vertically. If there is no vertical overlap it + -- "dovetails" the two onto one line. + ($$) :: doc -> doc -> doc + + lines_ :: [Line doc] -> doc + lines_ = vcat . map line + {-# INLINE CONLIKE lines_ #-} + + -- | Concatenate @doc@s vertically with dovetailing. + vcat :: [doc] -> doc + vcat ls = foldr ($$) empty ls + {-# INLINE CONLIKE vcat #-} + + -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualDoc :: SDoc -> HDoc -> doc + +instance IsOutput SDoc where + empty = docToSDoc $ Pretty.empty + {-# INLINE CONLIKE empty #-} + docWithContext = sdocWithContext + {-# INLINE docWithContext #-} + +instance IsLine SDoc where + char c = docToSDoc $ Pretty.char c + {-# INLINE CONLIKE char #-} + text s = docToSDoc $ Pretty.text s + {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s + {-# INLINE CONLIKE ftext #-} + ztext s = docToSDoc $ Pretty.ztext s + {-# INLINE CONLIKE ztext #-} + (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<>) #-} + (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<+>) #-} + hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hcat #-} + hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hsep #-} + sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE sep #-} + fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE fsep #-} + dualLine s _ = s + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc SDoc where + type Line SDoc = SDoc + line = id + {-# INLINE line #-} + lines_ = vcat + {-# INLINE lines_ #-} + + ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE ($$) #-} + vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE vcat #-} + dualDoc s _ = s + {-# INLINE CONLIKE dualDoc #-} + +instance IsOutput HLine where + empty = HLine (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsOutput HDoc where + empty = HDoc (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsLine HLine where + char c = HLine (\_ h -> bPutChar h c) + {-# INLINE CONLIKE char #-} + text str = HLine (\_ h -> bPutStr h str) + {-# INLINE CONLIKE text #-} + ftext fstr = HLine (\_ h -> bPutFS h fstr) + {-# INLINE CONLIKE ftext #-} + ztext fstr = HLine (\_ h -> bPutFZS h fstr) + {-# INLINE CONLIKE ztext #-} + + HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE (<>) #-} + f <+> g = f <> char ' ' <> g + {-# INLINE CONLIKE (<+>) #-} + sep = hsep + {-# INLINE sep #-} + fsep = hsep + {-# INLINE fsep #-} + + dualLine _ h = h + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc HDoc where + type Line HDoc = HLine + line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n') + {-# INLINE CONLIKE line #-} + HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE ($$) #-} + dualDoc _ h = h + {-# INLINE CONLIKE dualDoc #-} diff --git a/compiler/GHC/Utils/Outputable.hs-boot b/compiler/GHC/Utils/Outputable.hs-boot deleted file mode 100644 --- a/compiler/GHC/Utils/Outputable.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module GHC.Utils.Outputable where - -import GHC.Prelude - -data SDoc -data PprStyle -data SDocContext - -text :: String -> SDoc diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs --- a/compiler/GHC/Utils/Panic.hs +++ b/compiler/GHC/Utils/Panic.hs @@ -12,30 +12,37 @@ -- It's hard to put these functions anywhere else without causing -- some unnecessary loops in the module dependency graph. module GHC.Utils.Panic - ( GhcException(..) + ( -- * GHC exception type + GhcException(..) , showGhcException , showGhcExceptionUnsafe , throwGhcException , throwGhcExceptionIO , handleGhcException + -- * Command error throwing patterns , pgmError , panic , pprPanic - , assertPanic - , assertPprPanic - , assertPpr - , assertPprM - , massertPpr , sorry , panicDoc , sorryDoc , pgmErrorDoc , cmdLineError , cmdLineErrorIO + -- ** Assertions + , assertPanic + , assertPprPanic + , assertPpr + , assertPprMaybe + , assertPprM + , massertPpr + + -- * Call stacks , callStackDoc , prettyCallStackDoc + -- * Exception utilities , Exception.Exception(..) , showException , safeShowException @@ -46,7 +53,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Stack import GHC.Utils.Outputable @@ -309,6 +316,12 @@ if debugIsOn && not cond 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 #-} diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs --- a/compiler/GHC/Utils/Panic/Plain.hs +++ b/compiler/GHC/Utils/Panic/Plain.hs @@ -28,7 +28,7 @@ import GHC.Utils.Constants import GHC.Utils.Exception as Exception import GHC.Stack -import GHC.Prelude +import GHC.Prelude.Basic import System.IO.Unsafe -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits @@ -101,11 +101,12 @@ throwPlainGhcException = Exception.throw -- | Panics and asserts. -panic, sorry, pgmError :: String -> a +panic, sorry, pgmError :: HasCallStack => String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x + let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) if null stack - then throwPlainGhcException (PlainPanic x) + then throwPlainGhcException (PlainPanic (x ++ '\n' : doc)) else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) sorry x = throwPlainGhcException (PlainSorry x) diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -79,7 +79,7 @@ lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, + parens, brackets, braces, quotes, squotes, quote, doubleQuotes, maybeParens, -- ** Combining documents @@ -93,6 +93,7 @@ -- * Predicates on documents isEmpty, + docHead, -- * Rendering documents @@ -107,11 +108,12 @@ -- ** GHC-specific rendering printDoc, printDoc_, - bufLeftRender -- performance hack + bufLeftRender, printLeftRender -- performance hack ) where -import GHC.Prelude hiding (error) +import GHC.Prelude.Basic hiding (error) +import Control.Applicative ((<|>)) import GHC.Utils.BufHandle import GHC.Data.FastString @@ -350,6 +352,37 @@ isEmpty Empty = True isEmpty _ = False +-- | Get the first character of a document. We also return a new document, +-- equivalent to the original one but faster to render. Use it to avoid work +-- duplication. +docHead :: Doc -> (Maybe Char, Doc) +docHead d = (headChar, rdoc) + where + rdoc = reduceDoc d + headChar = go rdoc + + go :: RDoc -> Maybe Char + go (Union p q) = go (first p q) + go (Nest _ p) = go p + go Empty = Nothing + go (NilAbove _) = Just '\n' + go (TextBeside td _ p) = go_td td <|> go p + go NoDoc = error "docHead: NoDoc" + go (Above {}) = error "docHead: Above" + go (Beside {}) = error "docHead: Beside" + + go_td :: TextDetails -> Maybe Char + go_td (Chr c) = Just c + go_td (Str s) = go_str s + go_td (PStr s) = go_str (unpackFS s) -- O(1) because unpackFS is lazy + go_td (ZStr s) = go_str (zStringTakeN 1 s) + go_td (LStr s) = go_str (unpackPtrStringTakeN 1 s) + go_td (RStr n c) = if n > 0 then Just c else Nothing + + go_str :: String -> Maybe Char + go_str [] = Nothing + go_str (c:_) = Just c + {- Q: What is the reason for negative indentation (i.e. argument to indent is < 0) ? @@ -429,10 +462,12 @@ parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quotes :: Doc -> Doc -- ^ Wrap document in @\`...\'@ +squotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ quote :: Doc -> Doc doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ quotes p = char '`' <> p <> char '\'' +squotes p = char '\'' <> p <> char '\'' quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' @@ -1137,16 +1172,14 @@ bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft !_ NoDoc = error "layLeft: NoDoc" layLeft b (Union p q) = layLeft b $! first p q layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c + put !b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s diff --git a/compiler/GHC/Utils/Ppr/Colour.hs b/compiler/GHC/Utils/Ppr/Colour.hs --- a/compiler/GHC/Utils/Ppr/Colour.hs +++ b/compiler/GHC/Utils/Ppr/Colour.hs @@ -1,5 +1,5 @@ module GHC.Utils.Ppr.Colour where -import GHC.Prelude +import GHC.Prelude.Basic import Data.Maybe (fromMaybe) import GHC.Data.Bool diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs --- a/compiler/GHC/Utils/Trace.hs +++ b/compiler/GHC/Utils/Trace.hs @@ -13,7 +13,18 @@ ) where -import GHC.Prelude +{- Note [Exporting pprTrace from GHC.Prelude] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For our own sanity we want to export pprTrace from GHC.Prelude. +Since calls to traces should never be performance sensitive it's okay for these +to be source imports/exports. However we still need to make sure that all +transitive imports from Trace.hs-boot do not import GHC.Prelude. + +To get there we import the basic GHC.Prelude.Basic prelude instead of GHC.Prelude +within the transitive dependencies of Trace.hs +-} + +import GHC.Prelude.Basic import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Panic @@ -28,7 +39,7 @@ pprTrace :: String -> SDoc -> a -> a pprTrace str doc x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x + | otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) @@ -69,7 +80,7 @@ warnPprTrace _ _s _msg x | unsafeHasNoDebugOutput = x warnPprTrace False _s _msg x = x warnPprTrace True s msg x - = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + = pprDebugAndThen traceSDocContext trace (text "WARNING:") (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) x @@ -78,7 +89,7 @@ pprTraceUserWarning :: HasCallStack => SDoc -> a -> a pprTraceUserWarning msg x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + | otherwise = pprDebugAndThen traceSDocContext trace (text "WARNING:") (msg $$ withFrozenCallStack traceCallStackDoc ) x diff --git a/compiler/Language/Haskell/Syntax.hs b/compiler/Language/Haskell/Syntax.hs --- a/compiler/Language/Haskell/Syntax.hs +++ b/compiler/Language/Haskell/Syntax.hs @@ -20,20 +20,29 @@ module Language.Haskell.Syntax.Binds, module Language.Haskell.Syntax.Decls, module Language.Haskell.Syntax.Expr, + module Language.Haskell.Syntax.ImpExp, module Language.Haskell.Syntax.Lit, + module Language.Haskell.Syntax.Module.Name, module Language.Haskell.Syntax.Pat, module Language.Haskell.Syntax.Type, + module Language.Haskell.Syntax.Concrete, module Language.Haskell.Syntax.Extension, + ModuleName(..), HsModule(..) ) where import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Expr +import Language.Haskell.Syntax.ImpExp +import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type +import Data.Maybe (Maybe) + {- Note [Language.Haskell.Syntax.* Hierarchy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -55,5 +64,42 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow -} +-- | Haskell Module +-- +-- All we actually declare here is the top-level structure for a module. +data HsModule p + = -- | 'GHC.Parser.Annotation.AnnKeywordId's + -- + -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere' + -- + -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around + -- hsmodImports,hsmodDecls if this style is used. --- TODO Add TTG parameter to 'HsModule' and move here. + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + HsModule { + hsmodExt :: XCModule p, + -- ^ HsModule extension point + hsmodName :: Maybe (XRec p ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (XRec p [LIE p]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @Just []@: export /nothing/ + -- + -- - @Just [...]@: as you would expect... + -- + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' + -- ,'GHC.Parser.Annotation.AnnClose' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + hsmodImports :: [LImportDecl p], + hsmodDecls :: [LHsDecl p] + -- ^ Type, class, value, and interface signature decls + } + | XModule !(XXModule p) + diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Basic.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +module Language.Haskell.Syntax.Basic where + +import Data.Data +import Data.Eq +import Data.Ord +import Data.Bool +import Data.Int (Int) + +import GHC.Data.FastString (FastString) +import Control.DeepSeq + +{- +************************************************************************ +* * +Boxity +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +{- +************************************************************************ +* * +Counts and indices +* * +************************************************************************ +-} + +-- | The width of an unboxed sum +type SumWidth = Int + +-- | A *one-index* constructor tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +newtype FieldLabelString = FieldLabelString { field_label:: FastString } + deriving (Data, Eq, NFData) + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | See Note [Roles] in GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data) + +{- +************************************************************************ +* * +Source Strictness and Unpackedness +* * +************************************************************************ +-} + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data) diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -21,8 +21,6 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Binds where -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( LHsExpr , MatchGroup @@ -32,19 +30,17 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Name.Reader(RdrName) -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Types.Tickish -import GHC.Types.Var -import GHC.Types.Fixity -import GHC.Data.Bag -import GHC.Data.BooleanFormula (LBooleanFormula) -import GHC.Utils.Outputable -import GHC.Utils.Panic (pprPanic) +import GHC.Types.Fixity (Fixity) +import GHC.Data.Bag (Bag) +import GHC.Types.Basic (InlinePragma) +import GHC.Data.BooleanFormula (LBooleanFormula) +import GHC.Types.SourceText (StringLiteral) + import Data.Void +import Data.Bool +import Data.Maybe {- ************************************************************************ @@ -203,9 +199,8 @@ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr - fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + fun_matches :: MatchGroup idR (LHsExpr idR) -- ^ The payload - fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any } -- | Pattern Binding @@ -224,10 +219,7 @@ | PatBind { pat_ext :: XPatBind idL idR, pat_lhs :: LPat idL, - pat_rhs :: GRHSs idR (LHsExpr idR), - pat_ticks :: ([CoreTickish], [[CoreTickish]]) - -- ^ Ticks to put on the rhs, if any, and ticks to put on - -- the bound variables. + pat_rhs :: GRHSs idR (LHsExpr idR) } -- | Variable Binding @@ -372,13 +364,6 @@ -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) - -- | A type signature in generated code, notably the code - -- generated for record selectors. We simply record - -- the desired Id itself, replete with its name, type - -- and IdDetails. Otherwise it's just like a type - -- signature: there should be an accompanying binding - | IdSig (XIdSig pass) Id - -- | An ordinary fixity declaration -- -- > infixl 8 *** @@ -435,8 +420,7 @@ -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in GHC.Types.SourceText + | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) -- | A minimal complete definition pragma -- @@ -447,9 +431,7 @@ -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | MinimalSig (XMinimalSig pass) - SourceText (LBooleanFormula (LIdP pass)) - -- Note [Pragma source text] in GHC.Types.SourceText + | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass)) -- | A "set cost centre" pragma for declarations -- @@ -460,7 +442,6 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText (LIdP pass) -- Function name (Maybe (XRec pass StringLiteral)) -- | A complete match pragma @@ -471,7 +452,6 @@ -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass) - SourceText (XRec pass [LIdP pass]) (Maybe (LIdP pass)) | XSig !(XXSig pass) @@ -490,7 +470,7 @@ isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures isTypeLSig (unXRec @p -> TypeSig {}) = True isTypeLSig (unXRec @p -> ClassOpSig {}) = True -isTypeLSig (unXRec @p -> IdSig {}) = True +isTypeLSig (unXRec @p -> XSig {}) = True isTypeLSig _ = False isSpecLSig :: forall p. UnXRec p => LSig p -> Bool @@ -526,36 +506,6 @@ isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _ = False -hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = text "type signature" -hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig _ is_deflt _ _) - | is_deflt = text "default type signature" - | otherwise = text "class method signature" -hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" -hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" --- Using the 'inlinePragmaName' function ensures that the pragma name for any --- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted --- from the InlineSpec field of the pragma. -hsSigDoc (SpecInstSig _ src _) = text (extractSpecPragName src) <+> text "instance pragma" -hsSigDoc (FixSig {}) = text "fixity declaration" -hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" -hsSigDoc (SCCFunSig {}) = text "SCC pragma" -hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" -hsSigDoc (XSig {}) = text "XSIG TTG extension" - --- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src --- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE --- instance pragma of the form: "SourceText {-# SPECIALIZE" --- --- Extraction ensures that all variants of the pragma name (with a 'Z' or an --- 'S') are output exactly as used in the pragma. -extractSpecPragName :: SourceText -> String -extractSpecPragName srcTxt = case (words $ show srcTxt) of - (_:_:pragName:_) -> filter (/= '\"') pragName - _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) - {- ************************************************************************ * * @@ -605,9 +555,6 @@ making the distinction between the two names clear. -} -instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - -- | Haskell Pattern Synonym Direction data HsPatSynDir id diff --git a/compiler/Language/Haskell/Syntax/Concrete.hs b/compiler/Language/Haskell/Syntax/Concrete.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Concrete.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Bits of concrete syntax (tokens, layout). + +module Language.Haskell.Syntax.Concrete + ( LHsToken, LHsUniToken, + HsToken(HsTok), + HsUniToken(HsNormalTok, HsUnicodeTok), + LayoutInfo(ExplicitBraces, VirtualBraces, NoLayoutInfo) + ) where + +import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) +import Data.Data +import Language.Haskell.Syntax.Extension + +type LHsToken tok p = XRec p (HsToken tok) +type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) + +-- | A token stored in the syntax tree. For example, when parsing a +-- let-expression, we store @HsToken "let"@ and @HsToken "in"@. +-- The locations of those tokens can be used to faithfully reproduce +-- (exactprint) the original program text. +data HsToken (tok :: Symbol) = HsTok + +-- | With @UnicodeSyntax@, there might be multiple ways to write the same +-- token. For example an arrow could be either @->@ or @→@. This choice must be +-- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we +-- introduce @HsUniToken "->" "→"@. +-- +-- See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to +-- avoid a dependency. +data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok + +deriving instance KnownSymbol tok => Data (HsToken tok) +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) + +-- | Layout information for declarations. +data LayoutInfo pass = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + ExplicitBraces !(LHsToken "{" pass) !(LHsToken "}" pass) + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + VirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + NoLayoutInfo diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -2,8 +2,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -14,12 +16,9 @@ {- (c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +(c) The GRASP/@type@AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* -- | Abstract syntax of global declarations. @@ -30,23 +29,23 @@ -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, + isTypeDataDefnCons, StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, DataDeclRn(..), + TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - countTyClDecls, tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), pprFlavour, + InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, @@ -57,16 +56,14 @@ DerivDecl(..), LDerivDecl, -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, - derivStrategyName, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, - pprFullRuleName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice - SpliceExplicitFlag(..), + SpliceDecoration(..), SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), @@ -92,33 +89,39 @@ ) where -- friends: -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsSplice ) + ( HsExpr, HsUntypedSplice ) -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.Type -import GHC.Hs.Doc -import GHC.Core.TyCon -import GHC.Types.Basic -import GHC.Types.ForeignCall +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension -import GHC.Types.Name.Set -import GHC.Types.Fixity +import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Basic (Role) --- others: -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Types.SrcLoc -import GHC.Types.SourceText -import GHC.Core.Type -import GHC.Unit.Module.Warnings +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation) +import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) +import GHC.Types.Fixity (LexicalFixity) -import GHC.Data.Maybe -import Data.Data hiding (TyCon,Fixity, Infix) +import GHC.Core.Type (Specificity) +import GHC.Unit.Module.Warnings (WarningTxt) + +import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST + +import Control.Monad +import Data.Data hiding (TyCon, Fixity, Infix) import Data.Void +import Data.Maybe +import Data.String +import Data.Function +import Data.Eq +import Data.Int +import Data.Bool +import Prelude (Show) +import qualified Data.List +import Data.Foldable +import Data.Traversable +import Data.List.NonEmpty (NonEmpty (..)) {- ************************************************************************ @@ -245,10 +248,18 @@ data SpliceDecl p = SpliceDecl -- Top level splice (XSpliceDecl p) - (XRec p (HsSplice p)) - SpliceExplicitFlag + (XRec p (HsUntypedSplice p)) + SpliceDecoration -- Whether $( ) variant found, for pretty printing | XSpliceDecl !(XXSpliceDecl p) +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = DollarSplice -- ^ $splice + | BareSplice -- ^ bare splice + deriving (Data, Eq, Show) + {- ************************************************************************ * * @@ -412,7 +423,7 @@ -- 'GHC.Parser.Annotation.AnnEqual', -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renamer, FVs , tcdLName :: LIdP pass -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these @@ -444,6 +455,8 @@ -- 'GHC.Parser.Annotation.AnnRarrow' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdLayout :: !(LayoutInfo pass), -- ^ Explicit or virtual braces + -- See Note [Class LayoutInfo] tcdCtxt :: Maybe (LHsContext pass), -- ^ Context... tcdLName :: LIdP pass, -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables @@ -465,12 +478,6 @@ type LHsFunDep pass = XRec pass (FunDep pass) -data DataDeclRn = DataDeclRn - { tcdDataCusk :: Bool -- ^ does this have a CUSK? - -- See Note [CUSKs: complete user-supplied kind signatures] - , tcdFVs :: NameSet } - deriving Data - {- Note [TyVar binders for associated decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For an /associated/ data, newtype, or type-family decl, the LHsQTyVars @@ -564,22 +571,7 @@ tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d -countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls -countTyClDecls decls - = (count isClassDecl decls, - count isSynDecl decls, -- excluding... - count isDataTy decls, -- ...family... - count isNewTy decls, -- ...instances - count isFamilyDecl decls) - where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True - isDataTy _ = False - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True - isNewTy _ = False - - {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied @@ -599,7 +591,7 @@ Examples: * data T1 (a :: *->*) (b :: *) = .... - -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * + -- Has CUSK; equivalent to T1 :: (*->*) -> * -> * * data T2 a b = ... -- No CUSK; we do not want to guess T2 :: * -> * -> * @@ -710,16 +702,16 @@ tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] -tyClGroupTyClDecls = concatMap group_tyclds +tyClGroupTyClDecls = Data.List.concatMap group_tyclds tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] -tyClGroupInstDecls = concatMap group_instds +tyClGroupInstDecls = Data.List.concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] -tyClGroupRoleDecls = concatMap group_roles +tyClGroupRoleDecls = Data.List.concatMap group_roles tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass] -tyClGroupKindSigs = concatMap group_kisigs +tyClGroupKindSigs = Data.List.concatMap group_kisigs {- ********************************************************************* @@ -871,18 +863,6 @@ | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -------------- Pretty printing FamilyDecls ----------- - -pprFlavour :: FamilyInfo pass -> SDoc -pprFlavour DataFamily = text "data" -pprFlavour OpenTypeFamily = text "type" -pprFlavour (ClosedTypeFamily {}) = text "type" - -instance Outputable (FamilyInfo pass) where - ppr info = pprFlavour info <+> text "family" - - - {- ********************************************************************* * * Data types and data constructors @@ -899,7 +879,6 @@ -- data/newtype instance T [a] = -- @ HsDataDefn { dd_ext :: XCHsDataDefn pass, - dd_ND :: NewOrData, dd_ctxt :: Maybe (LHsContext pass), -- ^ Context dd_cType :: Maybe (XRec pass CType), dd_kindSig:: Maybe (LHsKind pass), @@ -910,7 +889,7 @@ -- -- Always @Nothing@ for H98-syntax decls - dd_cons :: [LConDecl pass], + dd_cons :: DataDefnCons (LConDecl pass), -- ^ Data constructors -- -- For @data T a = T1 | T2 a@ @@ -1007,17 +986,35 @@ for CUSKs, so this would be a separate feature. -} +-- | When we only care whether a data-type declaration is `data` or `newtype`, but not what constructors it has data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ - deriving( Eq, Data ) -- Needed because Demand derives Eq + deriving ( Eq, Data ) -- Needed because Demand derives Eq --- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour -newOrDataToFlavour NewType = NewtypeFlavour -newOrDataToFlavour DataType = DataTypeFlavour +-- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. +data DataDefnCons a + = NewTypeCon -- @newtype N x = MkN blah@ + a -- Info about the single data constructor @MkN@ + | DataTypeCons + Bool -- True <=> type data T x = ... + -- See Note [Type data declarations] in GHC.Rename.Module + -- False <=> data T x = ... + [a] -- The (possibly empty) list of data constructors + deriving ( Eq, Data, Foldable, Functor, Traversable ) -- Needed because Demand derives Eq +dataDefnConsNewOrData :: DataDefnCons a -> NewOrData +dataDefnConsNewOrData = \ case + NewTypeCon _ -> NewType + DataTypeCons _ _ -> DataType + +-- | Are the constructors within a @type data@ declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataDefnCons :: DataDefnCons a -> Bool +isTypeDataDefnCons (NewTypeCon _) = False +isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data + -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when @@ -1053,8 +1050,8 @@ data ConDecl pass = ConDeclGADT { con_g_ext :: XConDeclGADT pass - , con_names :: [LIdP pass] - + , con_names :: NonEmpty (LIdP pass) + , con_dcolon :: !(LHsUniToken "::" "∷" pass) -- The following fields describe the type after the '::' -- See Note [GADT abstract syntax] , con_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) @@ -1218,10 +1215,6 @@ = PrefixConGADT [HsScaled pass (LBangType pass)] | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass) -instance Outputable NewOrData where - ppr NewType = text "newtype" - ppr DataType = text "data" - {- ************************************************************************ * * @@ -1469,14 +1462,6 @@ | ViaStrategy (XViaStrategy pass) -- ^ @-XDerivingVia@ --- | A short description of a @DerivStrategy'@. -derivStrategyName :: DerivStrategy a -> SDoc -derivStrategyName = text . go - where - go StockStrategy {} = "stock" - go AnyclassStrategy {} = "anyclass" - go NewtypeStrategy {} = "newtype" - go ViaStrategy {} = "via" {- ************************************************************************ @@ -1525,13 +1510,13 @@ { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fi :: ForeignImport } + , fd_fi :: ForeignImport pass } | ForeignExport { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fe :: ForeignExport } + , fd_fe :: ForeignExport pass } -- ^ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign', -- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport', @@ -1552,27 +1537,26 @@ -- Specification Of an imported external entity in dependence on the calling -- convention -- -data ForeignImport = -- import of a C entity - -- - -- * the two strings specifying a header file or library - -- may be empty, which indicates the absence of a - -- header or object specification (both are not used - -- in the case of `CWrapper' and when `CFunction' - -- has a dynamic target) - -- - -- * the calling convention is irrelevant for code - -- generation in the case of `CLabel', but is needed - -- for pretty printing - -- - -- * `Safety' is irrelevant for `CLabel' and `CWrapper' - -- - CImport (Located CCallConv) -- ccall or stdcall - (Located Safety) -- interruptible, safe or unsafe - (Maybe Header) -- name of C header - CImportSpec -- details of the C entity - (Located SourceText) -- original source text for - -- the C entity - deriving Data +data ForeignImport pass = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (XCImport pass) + (XRec pass CCallConv) -- ccall or stdcall + (XRec pass Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + | XForeignImport !(XXForeignImport pass) -- details of an external C entity -- @@ -1585,47 +1569,10 @@ -- specification of an externally exported entity in dependence on the calling -- convention -- -data ForeignExport = CExport (Located CExportSpec) -- contains the calling - -- convention - (Located SourceText) -- original source text for - -- the C entity - deriving Data +data ForeignExport pass = CExport (XCExport pass) (XRec pass CExportSpec) -- contains the calling convention + | XForeignExport !(XXForeignExport pass) --- pretty printing of foreign declarations --- -instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec (L _ srcText)) = - ppr cconv <+> ppr safety - <+> pprWithSourceText srcText (pprCEntity spec "") - where - pp_hdr = case mHeader of - Nothing -> empty - Just (Header _ header) -> ftext header - - pprCEntity (CLabel lbl) _ = - doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = - if dqNeeded then doubleQuotes ce else empty - where - dqNeeded = (take 6 src == "static") - || isJust mHeader - || not isFun - || st /= NoSourceText - ce = - -- We may need to drop leading spaces first - (if take 6 src == "static" then text "static" else empty) - <+> pp_hdr - <+> (if isFun then empty else text "value") - <+> (pprWithSourceText st empty) - pprCEntity (CFunction DynamicTarget) _ = - doubleQuotes $ text "dynamic" - pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" - -instance Outputable ForeignExport where - ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = - ppr cconv <+> char '"' <> ppr lbl <> char '"' - {- ************************************************************************ * * @@ -1637,10 +1584,8 @@ -- | Located Rule Declarations type LRuleDecls pass = XRec pass (RuleDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass - , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } | XRuleDecls !(XXRuleDecls pass) @@ -1652,7 +1597,7 @@ = HsRule -- Source rule { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: XRec pass (SourceText,RuleName) + , rd_name :: XRec pass RuleName -- ^ Note [Pragma source text] in "GHC.Types.Basic" , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] @@ -1672,9 +1617,6 @@ -- 'GHC.Parser.Annotation.AnnEqual', | XRuleDecl !(XXRuleDecl pass) -data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS - deriving Data - -- | Located Rule Binder type LRuleBndr pass = XRec pass (RuleBndr pass) @@ -1692,9 +1634,6 @@ collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] -pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc -pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) - {- ************************************************************************ * * @@ -1715,10 +1654,6 @@ deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) --- Okay, I need to reconstruct the document comments, but for now: -instance Outputable (DocDecl name) where - ppr _ = text "" - docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d @@ -1738,10 +1673,8 @@ -- | Located Warning Declarations type LWarnDecls pass = XRec pass (WarnDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass - , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } | XWarnDecls !(XXWarnDecls pass) @@ -1768,7 +1701,6 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText (AnnProvenance pass) (XRec pass (HsExpr pass)) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnType' diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -6,13 +6,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -23,37 +20,30 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -import GHC.Prelude - +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds -- others: -import GHC.Core.DataCon (FieldLabelString) -import GHC.Types.Name -import GHC.Types.Basic -import GHC.Types.Fixity -import GHC.Types.Name.Reader -import GHC.Types.SourceText -import GHC.Types.SrcLoc +import GHC.Types.Fixity (LexicalFixity(Infix), Fixity) +import GHC.Types.SourceText (StringLiteral, SourceText) + import GHC.Unit.Module (ModuleName) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString -import GHC.Core.Type +import GHC.Data.FastString (FastString) -- libraries: import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) - +import Data.Bool +import Data.Either +import Data.Eq +import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) +import GHC.Types.Name.Reader {- Note [RecordDotSyntax field updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -107,7 +97,7 @@ @ The @fbind@ rule is then given the type @fbind :: { forall b. -DisambECP b => PV (Fbind b) }@ accomodating both alternatives: +DisambECP b => PV (Fbind b) }@ accommodating both alternatives: @ type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) @@ -144,38 +134,6 @@ newtype FieldLabelStrings p = FieldLabelStrings [XRec p (DotFieldOcc p)] -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where - ppr (FieldLabelStrings flds) = - hcat (punctuate dot (map (ppr . unXRec @p) flds)) - -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where - pprInfixOcc = pprFieldLabelStrings - pprPrefixOcc = pprFieldLabelStrings - -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprInfixOcc . unLoc - -pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc -pprFieldLabelStrings (FieldLabelStrings flds) = - hcat (punctuate dot (map (ppr . unXRec @p) flds)) - -pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) - => FieldLabelStrings p -> SDoc -pprPrefixFieldLabelStrings (FieldLabelStrings flds) = - hcat (punctuate dot (map (pprPrefixFieldLabelString . unXRec @p) flds)) - -pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc -pprPrefixFieldLabelString (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s -pprPrefixFieldLabelString XDotFieldOcc{} = text "XDotFieldOcc" - -pprPrefixFastString :: FastString -> SDoc -pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) - -instance UnXRec p => Outputable (DotFieldOcc p) where - ppr (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s - ppr XDotFieldOcc{} = text "XDotFieldOcc" - -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg @@ -241,47 +199,7 @@ -- etc type family SyntaxExpr p --- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable p = [(Name, HsExpr p)] --- See Note [CmdSyntaxTable] - {- -Note [CmdSyntaxTable] -~~~~~~~~~~~~~~~~~~~~~ -Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps -track of the methods needed for a Cmd. - -* Before the renamer, this list is an empty list - -* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ - For example, for the 'arr' method - * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) - * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) - where @arr_22@ is whatever 'arr' is in scope - -* After the type checker, it takes the form [(std_name, )] - where is the evidence for the method. This evidence is - instantiated with the class, but is still polymorphic in everything - else. For example, in the case of 'arr', the evidence has type - forall b c. (b->c) -> a b c - where 'a' is the ambient type of the arrow. This polymorphism is - important because the desugarer uses the same evidence at multiple - different types. - -This is Less Cool than what we normally do for rebindable syntax, which is to -make fully-instantiated piece of evidence at every use site. The Cmd way -is Less Cool because - * The renamer has to predict which methods are needed. - See the tedious GHC.Rename.Expr.methodNamesCmd. - - * The desugarer has to know the polymorphic type of the instantiated - method. This is checked by Inst.tcSyntaxName, but is less flexible - than the rest of rebindable syntax, where the type is less - pre-ordained. (And this flexibility is useful; for example we can - typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) --} - -{- Note [Record selectors in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how record selectors are expressed in GHC's AST: @@ -337,7 +255,7 @@ -- See Note [Located RdrNames] | HsUnboundVar (XUnboundVar p) - OccName -- ^ Unbound variable; also used for "holes" + RdrName -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope @@ -353,8 +271,9 @@ -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] - | HsOverLabel (XOverLabel p) FastString + | HsOverLabel (XOverLabel p) SourceText FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) + -- Note [Pragma source text] in GHC.Types.SourceText | HsIPVar (XIPVar p) HsIPName -- ^ Implicit parameter (not in use after typechecking) @@ -389,6 +308,7 @@ | HsAppType (XAppTypeE p) -- After typechecking: the type argument (LHsExpr p) + !(LHsToken "@" p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y @@ -454,8 +374,8 @@ -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p) - ConTag -- Alternative (one-based) - Arity -- Sum arity + ConTag -- Alternative (one-based) + SumWidth -- Sum arity (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', @@ -617,7 +537,8 @@ -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsSpliceE (XSpliceE p) (HsSplice p) + | HsTypedSplice (XTypedSplice p) (LHsExpr p) -- `$$z` or `$$(f 4)` + | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -664,7 +585,6 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText StringLiteral -- "set cost centre" SCC pragma -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', @@ -702,10 +622,6 @@ | LamCases -- ^ `\cases` deriving (Data, Eq) -lamCaseKeyword :: LamCaseVariant -> SDoc -lamCaseKeyword LamCase = text "\\case" -lamCaseKeyword LamCases = text "\\cases" - {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ @@ -850,11 +766,6 @@ -} ------------------------ -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - {- HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens. @@ -997,10 +908,6 @@ | HsFirstOrderApp deriving Data -pprHsArrType :: HsArrAppType -> SDoc -pprHsArrType HsHigherOrderApp = text "higher order arrow application" -pprHsArrType HsFirstOrderApp = text "first order arrow application" - {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. @@ -1052,20 +959,13 @@ -} data MatchGroup p body - = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result - , mg_alts :: XRec p [LMatch p body] -- The alternatives - , mg_origin :: Origin } + = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin + , mg_alts :: XRec p [LMatch p body] } -- The alternatives -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns | XMatchGroup !(XXMatchGroup p body) -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - } deriving Data - -- | Located Match type LMatch id body = XRec id (Match id body) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a @@ -1266,7 +1166,7 @@ (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] -- After renaming, the ids are the binders - -- bound by the stmts and used after themp + -- bound by the stmts and used after them | TransStmt { trS_ext :: XTransStmt idL idR body, -- Post typecheck, @@ -1554,84 +1454,38 @@ ************************************************************************ -} --- | Haskell Splice -data HsSplice id - = HsTypedSplice -- $$z or $$(f 4) - (XTypedSplice id) - SpliceDecoration -- Whether $$( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsUntypedSplice -- $z or $(f 4) - (XUntypedSplice id) - SpliceDecoration -- Whether $( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsQuasiQuote -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice - (XQuasiQuote id) - (IdP id) -- Splice point - (IdP id) -- Quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string - - -- AZ:TODO: use XSplice instead of HsSpliced - | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in - -- GHC.Rename.Splice. - -- This is the result of splicing a splice. It is produced by - -- the renamer and consumed by the typechecker. It lives only - -- between the two. - (XSpliced id) - ThModFinalizers -- TH finalizers produced by the splice. - (HsSplicedThing id) -- The result of splicing - | XSplice !(XXSplice id) -- Extension point; see Note [Trees That Grow] - -- in Language.Haskell.Syntax.Extension - --- | A splice can appear with various decorations wrapped around it. This data --- type captures explicitly how it was originally written, for use in the pretty --- printer. -data SpliceDecoration - = DollarSplice -- ^ $splice or $$splice - | BareSplice -- ^ bare splice - deriving (Data, Eq, Show) - -instance Outputable SpliceDecoration where - ppr x = text $ show x - - -isTypedSplice :: HsSplice id -> Bool -isTypedSplice (HsTypedSplice {}) = True -isTypedSplice _ = False -- Quasi-quotes are untyped splices +{- +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). --- | Finalizers produced by a splice with --- 'Language.Haskell.TH.Syntax.addModFinalizer' --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how --- this is used. --- -newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] +Briefly, one writes + [p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose type +should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be defined in +another module, because we are going to run it here. It's a bit like an +/untyped/ TH splice where the parser is applied the "stuff" as a string, thus: + $(p "stuff") --- A Data instance which ignores the argument of 'ThModFinalizers'. -instance Data ThModFinalizers where - gunfold _ z _ = z $ ThModFinalizers [] - toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +Notice that it's an /untyped/ TH splice: it can occur in patterns and types, as well +as in expressions; and it runs in the renamer. +-} --- | Haskell Spliced Thing --- --- Values that can result from running a splice. -data HsSplicedThing id - = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression - | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type - | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern +-- | Haskell Splice +data HsUntypedSplice id + = HsUntypedSpliceExpr -- $z or $(f 4) + (XUntypedSpliceExpr id) + (LHsExpr id) + | HsQuasiQuote -- See Note [Quasi-quote overview] + (XQuasiQuote id) + (IdP id) -- The quoter (the bit between `[` and `|`) + (XRec id FastString) -- The enclosed string -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data + | XUntypedSplice !(XXUntypedSplice id) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension -- | Haskell (Untyped) Quote = Expr + Pat + Type + Var data HsQuote p @@ -1802,114 +1656,3 @@ isMonadDoCompContext GhciStmtCtxt = False isMonadDoCompContext (DoExpr _) = False isMonadDoCompContext (MDoExpr _) = False - -matchSeparator :: HsMatchContext p -> SDoc -matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamCaseAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator LambdaExpr = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator StmtCtxt{} = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern - -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" -matchSeparator PatSyn = panic "unused" - -pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContext ctxt - | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt - | otherwise = text "a" <+> pprMatchContextNoun ctxt - where - want_an (FunRhs {}) = True -- Use "an" in front - want_an (ArrowMatchCtxt ProcExpr) = True - want_an (ArrowMatchCtxt KappaExpr) = True - want_an _ = False - -pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" - <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) -pprMatchContextNoun CaseAlt = text "case alternative" -pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternative" -pprMatchContextNoun IfAlt = text "multi-way if alternative" -pprMatchContextNoun RecUpd = text "record-update construct" -pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" -pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" -pprMatchContextNoun PatBindRhs = text "pattern binding" -pprMatchContextNoun PatBindGuards = text "pattern binding guards" -pprMatchContextNoun LambdaExpr = text "lambda abstraction" -pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c -pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" - $$ pprAStmtContext ctxt -pprMatchContextNoun PatSyn = text "pattern synonym declaration" - -pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" - <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) -pprMatchContextNouns PatBindGuards = text "pattern binding guards" -pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c -pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" - $$ pprAStmtContext ctxt -pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' - -pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc -pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" -pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" -pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternative within arrow notation" -pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction" - -pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc -pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" -pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternatives within arrow notation" -pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' - ------------------ -pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsStmtContext p -> SDoc -pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour -pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt - ------------------ -pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour -pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt -pprStmtContext ArrowExpr = text "'do' block in an arrow command" - --- Drop the inner contexts when reporting errors, else we get --- Unexpected transform statement --- in a transformed branch of --- transformed branch of --- transformed branch of monad comprehension -pprStmtContext (ParStmtCtxt c) = - ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) - (pprStmtContext c) -pprStmtContext (TransStmtCtxt c) = - ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) - (pprStmtContext c) - -pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc -pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour - where - pp_an = text "an" - pp_a = text "a" - article = case flavour of - MDoExpr Nothing -> pp_an - GhciStmtCtxt -> pp_an - _ -> pp_a -pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") -pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") -pprHsDoFlavour ListComp = text "list comprehension" -pprHsDoFlavour MonadComp = text "monad comprehension" -pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" - -prependQualified :: Maybe ModuleName -> SDoc -> SDoc -prependQualified Nothing t = t -prependQualified (Just _) t = text "qualified" <+> t diff --git a/compiler/Language/Haskell/Syntax/Expr.hs-boot b/compiler/Language/Haskell/Syntax/Expr.hs-boot --- a/compiler/Language/Haskell/Syntax/Expr.hs-boot +++ b/compiler/Language/Haskell/Syntax/Expr.hs-boot @@ -12,9 +12,9 @@ type role HsExpr nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal -type role HsSplice nominal +type role HsUntypedSplice nominal data HsExpr (i :: Type) -data HsSplice (i :: Type) +data HsUntypedSplice (i :: Type) data MatchGroup (a :: Type) (body :: Type) data GRHSs (a :: Type) (body :: Type) type family SyntaxExpr (i :: Type) diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -1,10 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc. +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -21,13 +21,16 @@ -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GHC.Prelude +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +import Data.Type.Equality (type (~)) +#endif -import GHC.TypeLits (Symbol, KnownSymbol) import Data.Data hiding ( Fixity ) import Data.Kind (Type) -import GHC.Utils.Outputable +import Data.Eq +import Data.Ord + {- Note [Trees That Grow] ~~~~~~~~~~~~~~~~~~~~~~ @@ -73,9 +76,6 @@ data NoExtField = NoExtField deriving (Data,Eq,Ord) -instance Outputable NoExtField where - ppr _ = text "NoExtField" - -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField @@ -111,9 +111,6 @@ data DataConCantHappen deriving (Data,Eq,Ord) -instance Outputable DataConCantHappen where - ppr = dataConCantHappen - -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a dataConCantHappen x = case x of {} @@ -354,6 +351,10 @@ type family XForeignImport x type family XForeignExport x type family XXForeignDecl x +type family XCImport x +type family XXForeignImport x +type family XCExport x +type family XXForeignExport x -- ------------------------------------- -- RuleDecls type families @@ -397,6 +398,12 @@ type family XXInjectivityAnn x -- ===================================================================== +-- Type families for the HsModule extension points + +type family XCModule x +type family XXModule x + +-- ===================================================================== -- Type families for the HsExpr extension points type family XVar x @@ -431,7 +438,8 @@ type family XArithSeq x type family XTypedBracket x type family XUntypedBracket x -type family XSpliceE x +type family XTypedSplice x +type family XUntypedSplice x type family XProc x type family XStatic x type family XTick x @@ -463,12 +471,10 @@ type family XXTupArg x -- ------------------------------------- --- HsSplice type families -type family XTypedSplice x -type family XUntypedSplice x -type family XQuasiQuote x -type family XSpliced x -type family XXSplice x +-- HsUntypedSplice type families +type family XUntypedSpliceExpr x +type family XQuasiQuote x +type family XXUntypedSplice x -- ------------------------------------- -- HsQuoteBracket type families @@ -653,6 +659,13 @@ type family XXType x -- --------------------------------------------------------------------- +-- HsTyLit type families +type family XNumTy x +type family XStrTy x +type family XCharTy x +type family XXTyLit x + +-- --------------------------------------------------------------------- -- HsForAllTelescope type families type family XHsForAllVis x type family XHsForAllInvis x @@ -681,6 +694,7 @@ -- ImportDecl type families type family XCImportDecl x type family XXImportDecl x +type family ImportDeclPkgQual x -- stores the package qualifier in an import statement -- ------------------------------------- -- IE type families @@ -695,7 +709,14 @@ type family XXIE x -- ------------------------------------- +-- IEWrappedName type families +type family XIEName p +type family XIEPattern p +type family XIEType p +type family XXIEWrappedName p + + -- ===================================================================== -- Misc @@ -707,27 +728,3 @@ -- ===================================================================== -- End of Type family definitions -- ===================================================================== - - - --- ===================================================================== --- Token information - -type LHsToken tok p = XRec p (HsToken tok) - -data HsToken (tok :: Symbol) = HsTok - -deriving instance KnownSymbol tok => Data (HsToken tok) - -type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) - --- With UnicodeSyntax, there might be multiple ways to write the same token. --- For example an arrow could be either "->" or "→". This choice must be --- recorded in order to exactprint such tokens, --- so instead of HsToken "->" we introduce HsUniToken "->" "→". --- --- See also IsUnicodeSyntax in GHC.Parser.Annotation; we do not use here to --- avoid a dependency. -data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok - -deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs b/compiler/Language/Haskell/Syntax/ImpExp.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/ImpExp.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Syntax.ImpExp where + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name + +import Data.Eq (Eq) +import Data.Ord (Ord) +import Text.Show (Show) +import Data.Data (Data) +import Data.Bool (Bool) +import Data.Maybe (Maybe) +import Data.String (String) +import Data.Int (Int) + +import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST + +{- +************************************************************************ +* * +Import and export declaration lists +* * +************************************************************************ + +One per import declaration in a module. +-} + +-- | Located Import Declaration +type LImportDecl pass = XRec pass (ImportDecl pass) + -- ^ When in a list this may have + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + +-- | If/how an import is 'qualified'. +data ImportDeclQualifiedStyle + = QualifiedPre -- ^ 'qualified' appears in prepositive position. + | QualifiedPost -- ^ 'qualified' appears in postpositive position. + | NotQualified -- ^ Not qualified. + deriving (Eq, Data) + +-- | Indicates whether a module name is referring to a boot interface (hs-boot +-- file) or regular module (hs file). We need to treat boot modules specially +-- when building compilation graphs, since they break cycles. Regular source +-- files and signature files are treated equivalently. +data IsBootInterface = NotBoot | IsBoot + deriving (Eq, Ord, Show, Data) + +-- | Import Declaration +-- +-- A single Haskell @import@ declaration. +data ImportDecl pass + = ImportDecl { + ideclExt :: XCImportDecl pass, + ideclName :: XRec pass ModuleName, -- ^ Module name. + ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. + ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. + ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module + ideclImportList :: Maybe (ImportListInterpretation, XRec pass [LIE pass]) + -- ^ Explicit import list (EverythingBut => hiding, names) + } + | XImportDecl !(XXImportDecl pass) + -- ^ + -- 'GHC.Parser.Annotation.AnnKeywordId's + -- + -- - 'GHC.Parser.Annotation.AnnImport' + -- + -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource + -- + -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified', + -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs', + -- 'GHC.Parser.Annotation.AnnVal' + -- + -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' attached + -- to location in ideclImportList + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + +-- | Whether the import list is exactly what to import, or whether `hiding` was +-- used, and therefore everything but what was listed should be imported +data ImportListInterpretation = Exactly | EverythingBut + deriving (Eq, Data) + +-- | Located Import or Export +type LIE pass = XRec pass (IE pass) + -- ^ When in a list this may have + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + +-- | Imported or exported entity. +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName pass) + -- ^ Imported or Exported Variable + + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) + -- ^ Imported or exported Thing with Absent list + -- + -- The thing is a Class/Type (can't tell) + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern', + -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- See Note [Located RdrNames] in GHC.Hs.Expr + | IEThingAll (XIEThingAll pass) (LIEWrappedName pass) + -- ^ Imported or exported Thing with All imported or exported + -- + -- The thing is a Class/Type and the All refers to methods/constructors + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose', + -- 'GHC.Parser.Annotation.AnnType' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- See Note [Located RdrNames] in GHC.Hs.Expr + + | IEThingWith (XIEThingWith pass) + (LIEWrappedName pass) + IEWildcard + [LIEWrappedName pass] + -- ^ Imported or exported Thing With given imported or exported + -- + -- The thing is a Class/Type and the imported or exported things are + -- methods/constructors and record fields; see Note [IEThingWith] + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose', + -- 'GHC.Parser.Annotation.AnnComma', + -- 'GHC.Parser.Annotation.AnnType' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) + -- ^ Imported or exported module contents + -- + -- (Export Only) + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading + | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation + | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc + | XIE !(XXIE pass) + +-- | Wildcard in an import or export sublist, like the @..@ in +-- @import Mod ( T(Mk1, Mk2, ..) )@. +data IEWildcard + = NoIEWildcard -- ^ no wildcard in this list + | IEWildcard Int -- ^ wildcard after the given \# of items in this list + -- The @Int@ is in the range [0..n], where n is the length + -- of the list. + deriving (Eq, Data) + +-- | A name in an import or export specification which may have +-- adornments. Used primarily for accurate pretty printing of +-- ParsedSource, and API Annotation placement. The +-- 'GHC.Parser.Annotation' is the location of the adornment in +-- the original source. +data IEWrappedName p + = IEName (XIEName p) (LIdP p) -- ^ no extra + | IEPattern (XIEPattern p) (LIdP p) -- ^ pattern X + | IEType (XIEType p) (LIdP p) -- ^ type (:+:) + | XIEWrappedName !(XXIEWrappedName p) + +-- | Located name with possible adornment +-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', +-- 'GHC.Parser.Annotation.AnnPattern' +type LIEWrappedName p = XRec p (IEWrappedName p) +-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs-boot b/compiler/Language/Haskell/Syntax/ImpExp.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/ImpExp.hs-boot @@ -0,0 +1,16 @@ +module Language.Haskell.Syntax.ImpExp where + +import Data.Eq +import Data.Ord +import Text.Show +import Data.Data + +-- This boot file should be short lived: As soon as the dependency on +-- `GHC.Hs.Doc` is gone we'll no longer have cycles and can get rid this file. + +data IsBootInterface = NotBoot | IsBoot + +instance Eq IsBootInterface +instance Ord IsBootInterface +instance Show IsBootInterface +instance Data IsBootInterface diff --git a/compiler/Language/Haskell/Syntax/Lit.hs b/compiler/Language/Haskell/Syntax/Lit.hs --- a/compiler/Language/Haskell/Syntax/Lit.hs +++ b/compiler/Language/Haskell/Syntax/Lit.hs @@ -18,18 +18,21 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -import GHC.Prelude - -import GHC.Types.Basic (PprPrec(..), topPrec ) -import GHC.Types.SourceText -import GHC.Core.Type -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString import Language.Haskell.Syntax.Extension +import GHC.Utils.Panic (panic) +import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText, negateIntegralLit, negateFractionalLit) +import GHC.Core.Type (Type) + +import GHC.Data.FastString (FastString, lexicalCompareFS) + import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) +import Data.Bool +import Data.Ord +import Data.Eq +import Data.Char +import Prelude (Integer) {- ************************************************************************ @@ -147,38 +150,3 @@ compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -instance Outputable OverLitVal where - ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs --- to be parenthesized under precedence @p@. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool -hsLitNeedsParens p = go - where - go (HsChar {}) = False - go (HsCharPrim {}) = False - go (HsString {}) = False - go (HsStringPrim {}) = False - go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 - go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 - go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x - go (XLit _) = False - --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal --- @ol@ needs to be parenthesized under precedence @p@. -hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool -hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv - where - go :: OverLitVal -> Bool - go (HsIntegral x) = p > topPrec && il_neg x - go (HsFractional x) = p > topPrec && fl_neg x - go (HsIsString {}) = False -hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/compiler/Language/Haskell/Syntax/Module/Name.hs b/compiler/Language/Haskell/Syntax/Module/Name.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Module/Name.hs @@ -0,0 +1,60 @@ +module Language.Haskell.Syntax.Module.Name where + +import Prelude + +import Data.Data +import Data.Char (isAlphaNum) +import Control.DeepSeq +import qualified Text.ParserCombinators.ReadP as Parse +import System.FilePath + +import GHC.Utils.Misc (abstractConstr) +import GHC.Data.FastString + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString deriving (Show, Eq) + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2 + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +parseModuleName :: Parse.ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 @@ -23,26 +23,35 @@ ConLikeP, HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldsArgs, ) where -import GHC.Prelude - -import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsSplice) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) -- friends: +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Basic --- others: -import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) -import GHC.Utils.Outputable -import GHC.Types.SrcLoc + -- libraries: +import Data.Maybe +import Data.Functor +import Data.Foldable +import Data.Traversable +import Data.Bool +import Data.Data +import Data.Eq +import Data.Ord +import Data.Int +import Data.Function +import qualified Data.List type LPat p = XRec p (Pat p) @@ -69,7 +78,9 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | AsPat (XAsPat p) - (LIdP p) (LPat p) -- ^ As pattern + (LIdP p) + !(LHsToken "@" p) + (LPat p) -- ^ As pattern -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation @@ -129,7 +140,7 @@ | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) - Arity -- Arity (INVARIANT: ≥ 2) + SumWidth -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : @@ -161,7 +172,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | SplicePat (XSplicePat p) - (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + (HsUntypedSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- | LitPat (XLitPat p) @@ -217,13 +228,19 @@ -- --------------------------------------------------------------------- +-- | Type argument in a data constructor pattern, +-- e.g. the @\@a@ in @f (Just \@a x) = ...@. +data HsConPatTyArg p = + HsConPatTyArg + !(LHsToken "@" p) + (HsPatSigType p) -- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) +type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps -hsConPatArgs (RecCon fs) = map (hfbRHS . unXRec @p) (rec_flds fs) +hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields @@ -234,10 +251,13 @@ -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], - rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] + rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) +-- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot` +newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int } + deriving (Data, Eq, Ord) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ @@ -336,34 +356,11 @@ -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) +hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) +hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS - -{- -************************************************************************ -* * -* Printing patterns -* * -************************************************************************ --} - -instance (Outputable arg, Outputable (XRec p (HsRecField p arg))) - => Outputable (HsRecFields p arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) - = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) - where - dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) - -instance (Outputable p, OutputableBndr p, Outputable arg) - => Outputable (HsFieldBind p arg) where - ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, - hfbPun = pun }) - = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -20,28 +19,28 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type ( - Mult, HsScaled(..), + HsScaled(..), hsMult, hsScaledThing, HsArrow(..), HsLinearArrowTokens(..), - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsType(..), LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), - HsPatSigType(..), HsPSRn(..), + HsPatSigType(..), HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsArg(..), numVisibleArgs, pprHsArgsApp, + HsArg(..), LHsTypeArg, LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), + PromotionFlag(..), isPromoted, ConDeclField(..), LConDeclField, @@ -56,33 +55,48 @@ hsPatSigType, ) where -import GHC.Prelude - -import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice ) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension -import GHC.Types.SourceText -import GHC.Types.Name( Name ) import GHC.Types.Name.Reader ( RdrName ) -import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import GHC.Core.Type -import GHC.Hs.Doc -import GHC.Types.Basic -import GHC.Types.Fixity -import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Data.FastString -import GHC.Utils.Misc ( count ) -import GHC.Parser.Annotation +import GHC.Core.DataCon( HsSrcBang(..) ) +import GHC.Core.Type (Specificity) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Hs.Doc (LHsDoc) +import GHC.Data.FastString (FastString) + import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Void +import Data.Maybe +import Data.Eq +import Data.Bool +import Data.Char +import Prelude (Integer) {- ************************************************************************ * * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +{- +************************************************************************ +* * \subsection{Bang annotations} * * ************************************************************************ @@ -155,7 +169,7 @@ HsOuterImplicit (implicit quantification, added by renamer) f :: a -> a -- Desugars to f :: forall {a}. a -> a - HsOuterExplicit (explicit user quantifiation): + HsOuterExplicit (explicit user quantification): f :: forall a. a -> a See Note [forall-or-nothing rule]. @@ -348,7 +362,7 @@ -- HsOuterImplicit (implicit quantification, added by renamer) -- f :: a -> a -- Desugars to f :: forall {a}. a -> a -- type instance F (a,b) = a->b --- HsOuterExplicit (explicit user quantifiation): +-- HsOuterExplicit (explicit user quantification): -- f :: forall a. a -> a -- type instance forall a b. F (a,b) = a->b -- @@ -422,14 +436,6 @@ } | XHsPatSigType !(XXHsPatSigType pass) --- | The extension field for 'HsPatSigType', which is only used in the --- renamer onwards. See @Note [Pattern signature binders and scoping]@. -data HsPSRn = HsPSRn - { hsps_nwcs :: [Name] -- ^ Wildcard names - , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names - } - deriving Data - -- | Located Haskell Signature Type type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only @@ -482,7 +488,7 @@ -- if you quantify a, you must also quantify b type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/ - -- quantifer, so the "nothing" part of the forall-or-nothing + -- quantifier, so the "nothing" part of the forall-or-nothing -- rule applies, and b is therefore implicitly quantified. -- Equivalently: forall b. forall a -> b -> b @@ -680,14 +686,6 @@ hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - -------------------------------------------------- -- | Haskell Type Variable Binder @@ -836,7 +834,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes + (HsUntypedSplice pass) -- Includes quasi-quotes -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@ @@ -881,7 +879,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + | HsTyLit (XTyLit pass) (HsTyLit pass) -- A promoted numeric literal. -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation @@ -896,30 +894,22 @@ | XHsType !(XXType pass) --- An escape hatch for tunnelling a Core 'Type' through 'HsType'. --- For more details on how this works, see: --- --- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" --- --- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" -type HsCoreTy = Type - --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in --- the following -- | Haskell Type Literal -data HsTyLit - = HsNumTy SourceText Integer - | HsStrTy SourceText FastString - | HsCharTy SourceText Char - deriving Data +data HsTyLit pass + = HsNumTy (XNumTy pass) Integer + | HsStrTy (XStrTy pass) FastString + | HsCharTy (XCharTy pass) Char + | XTyLit !(XXTyLit pass) -- | Denotes the type of arrows in the surface language 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 @@ -1046,7 +1036,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them = ConDeclField { cd_fld_ext :: XConDeclField pass, cd_fld_names :: [LFieldOcc pass], - -- ^ See Note [ConDeclField passs] + -- ^ See Note [ConDeclField pass] cd_fld_type :: LBangType pass, cd_fld_doc :: Maybe (LHsDoc pass)} -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' @@ -1081,14 +1071,8 @@ noTypeArgs :: [Void] noTypeArgs = [] -instance (Outputable tyarg, Outputable arg, Outputable rec) - => Outputable (HsConDetails tyarg arg rec) where - ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] - {- -Note [ConDeclField passs] +Note [ConDeclField pass] ~~~~~~~~~~~~~~~~~~~~~~~~~ A ConDeclField contains a list of field occurrences: these always @@ -1196,71 +1180,16 @@ ************************************************************************ -} --- Arguments in an expression/type after splitting +-- | Arguments in an expression/type after splitting data HsArg tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) -- SrcSpan is location of the `@` | HsArgPar SrcSpan -- See Note [HsArgPar] -numVisibleArgs :: [HsArg tm ty] -> Arity -numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False - -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) --- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ --- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix --- or infix. Examples: --- --- @ --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering --- @ -pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg tm ty] -> SDoc -pprHsArgsApp thing fixity (argl:argr:args) - | Infix <- fixity - = let pp_op_app = hsep [ ppr_single_hs_arg argl - , pprInfixOcc thing - , ppr_single_hs_arg argr ] in - case args of - [] -> pp_op_app - _ -> ppr_hs_args_prefix_app (parens pp_op_app) args - -pprHsArgsApp thing _fixity args - = ppr_hs_args_prefix_app (pprPrefixOcc thing) args - --- | Pretty-print a prefix identifier to a list of 'HsArg's. -ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) - => SDoc -> [HsArg tm ty] -> SDoc -ppr_hs_args_prefix_app acc [] = acc -ppr_hs_args_prefix_app acc (arg:args) = - case arg of - HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args - --- | Pretty-print an 'HsArg' in isolation. -ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg tm ty -> SDoc -ppr_single_hs_arg (HsValArg tm) = ppr tm -ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty --- GHC shouldn't be constructing ASTs such that this case is ever reached. --- Still, it's possible some wily user might construct their own AST that --- allows this to be reachable, so don't fail here. -ppr_single_hs_arg (HsArgPar{}) = empty - --- | This instance is meant for debug-printing purposes. If you wish to --- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. -instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp {- Note [HsArgPar] ~~~~~~~~~~~~~~~ @@ -1276,9 +1205,7 @@ -} --------------------------------- - {- ************************************************************************ * * @@ -1312,17 +1239,6 @@ , Eq (XXFieldOcc pass) ) => Eq (FieldOcc pass) -instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where - ppr = ppr . foLabel - -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where - pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel - pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel - -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprPrefixOcc . unLoc - -- | Located Ambiguous Field Occurence type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) @@ -1338,8 +1254,8 @@ -- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat". -- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (LocatedN RdrName) - | Ambiguous (XAmbiguous pass) (LocatedN RdrName) + = Unambiguous (XUnambiguous pass) (XRec pass RdrName) + | Ambiguous (XAmbiguous pass) (XRec pass RdrName) | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) @@ -1350,11 +1266,3 @@ * * ************************************************************************ -} - -instance Outputable HsTyLit where - ppr = ppr_tylit --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) -ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) -ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) diff --git a/compiler/Language/Haskell/Syntax/Type.hs-boot b/compiler/Language/Haskell/Syntax/Type.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Type.hs-boot @@ -0,0 +1,21 @@ +module Language.Haskell.Syntax.Type where + +import Data.Bool +import Data.Eq + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + +instance Eq PromotionFlag + +isPromoted :: PromotionFlag -> Bool diff --git a/compiler/MachRegs.h b/compiler/MachRegs.h --- a/compiler/MachRegs.h +++ b/compiler/MachRegs.h @@ -591,6 +591,92 @@ #define MAX_REAL_FLOAT_REG 6 #define MAX_REAL_DOUBLE_REG 6 +#elif defined(MACHREGS_wasm32) + +#define REG_R1 1 +#define REG_R2 2 +#define REG_R3 3 +#define REG_R4 4 +#define REG_R5 5 +#define REG_R6 6 +#define REG_R7 7 +#define REG_R8 8 +#define REG_R9 9 +#define REG_R10 10 + +#define REG_F1 11 +#define REG_F2 12 +#define REG_F3 13 +#define REG_F4 14 +#define REG_F5 15 +#define REG_F6 16 + +#define REG_D1 17 +#define REG_D2 18 +#define REG_D3 19 +#define REG_D4 20 +#define REG_D5 21 +#define REG_D6 22 + +#define REG_L1 23 + +#define REG_Sp 24 +#define REG_SpLim 25 +#define REG_Hp 26 +#define REG_HpLim 27 +#define REG_CCCS 28 + +/* ----------------------------------------------------------------------------- + The loongarch64 register mapping + + Register | Role(s) | Call effect + ------------+-----------------------------------------+------------- + zero | Hard-wired zero | - + ra | Return address | caller-saved + tp | Thread pointer | - + sp | Stack pointer | callee-saved + a0,a1 | Arguments / return values | caller-saved + a2..a7 | Arguments | caller-saved + t0..t8 | - | caller-saved + u0 | Reserve | - + fp | Frame pointer | callee-saved + s0..s8 | - | callee-saved + fa0,fa1 | Arguments / return values | caller-saved + fa2..fa7 | Arguments | caller-saved + ft0..ft15 | - | caller-saved + fs0..fs7 | - | callee-saved + + Each general purpose register as well as each floating-point + register is 64 bits wide, also, the u0 register is called r21 in some cases. + + -------------------------------------------------------------------------- */ +#elif defined(MACHREGS_loongarch64) + +#define REG(x) __asm__("$" #x) + +#define REG_Base s0 +#define REG_Sp s1 +#define REG_Hp s2 +#define REG_R1 s3 +#define REG_R2 s4 +#define REG_R3 s5 +#define REG_R4 s6 +#define REG_R5 s7 +#define REG_SpLim s8 + +#define REG_F1 fs0 +#define REG_F2 fs1 +#define REG_F3 fs2 +#define REG_F4 fs3 + +#define REG_D1 fs4 +#define REG_D2 fs5 +#define REG_D3 fs6 +#define REG_D4 fs7 + +#define MAX_REAL_FLOAT_REG 4 +#define MAX_REAL_DOUBLE_REG 4 + #else #error Cannot find platform to give register info for diff --git a/compiler/ghc-llvm-version.h b/compiler/ghc-llvm-version.h --- a/compiler/ghc-llvm-version.h +++ b/compiler/ghc-llvm-version.h @@ -3,9 +3,9 @@ #define __GHC_LLVM_VERSION_H__ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (15) +#define sUPPORTED_LLVM_VERSION_MAX (16) /* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (10) +#define sUPPORTED_LLVM_VERSION_MIN (11) #endif /* __GHC_LLVM_VERSION_H__ */ diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal new file mode 100644 --- /dev/null +++ b/compiler/ghc.cabal @@ -0,0 +1,880 @@ +Cabal-Version: 2.2 +-- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by +-- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. + +Name: ghc +Version: 9.6.1 +License: BSD-3-Clause +License-File: LICENSE +Author: The GHC Team +Maintainer: glasgow-haskell-users@haskell.org +Homepage: http://www.haskell.org/ghc/ +Synopsis: The GHC API +Description: + GHC's functionality can be useful for more things than just + compiling Haskell programs. Important use cases are programs + that analyse (and perhaps transform) Haskell code. Others + include loading Haskell code dynamically in a GHCi-like manner. + For this reason, a lot of GHC's functionality is made available + through this package. + . + See + for more information. +Category: Development +Build-Type: Custom + +extra-source-files: + GHC/Builtin/primops.txt.pp + GHC/Builtin/bytearray-ops.txt.pp + Unique.h + CodeGen.Platform.h + -- Shared with rts via hard-link at configure time. This is safer + -- for Windows, where symlinks don't work out of the box, so we + -- can't just commit some in git. + Bytecodes.h + ClosureTypes.h + FunTypes.h + MachRegs.h + ghc-llvm-version.h + + +custom-setup + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath + +Flag internal-interpreter + Description: Build with internal interpreter support. + Default: False + Manual: True + +Flag dynamic-system-linker + Description: The system can load dynamic code. This is not the case for musl. + Default: True + Manual: True + +-- hadrian disables this flag because the user may be building from a source +-- distribution where the parser has already been generated. +Flag build-tool-depends + Description: Use build-tool-depends + Default: True + +Library + Default-Language: Haskell2010 + Exposed: False + Includes: Unique.h + -- CodeGen.Platform.h -- invalid as C, skip + -- shared with rts via symlink + Bytecodes.h + ClosureTypes.h + FunTypes.h + ghc-llvm-version.h + + if flag(build-tool-depends) + build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants + + Build-Depends: base >= 4.11 && < 4.19, + deepseq >= 1.4 && < 1.5, + directory >= 1 && < 1.4, + process >= 1 && < 1.7, + bytestring >= 0.9 && < 0.12, + binary == 0.8.*, + time >= 1.4 && < 1.13, + containers >= 0.6.2.1 && < 0.7, + array >= 0.1 && < 0.6, + filepath >= 1 && < 1.5, + template-haskell == 2.20.*, + hpc == 0.6.*, + transformers >= 0.5 && < 0.7, + exceptions == 0.10.*, + stm, + ghc-boot == 9.6.1, + ghc-heap == 9.6.1, + ghci == 9.6.1 + + if os(windows) + Build-Depends: Win32 >= 2.3 && < 2.14 + else + Build-Depends: unix >= 2.7 && < 2.9 + + GHC-Options: -Wall + -Wno-name-shadowing + -Wnoncanonical-monad-instances + -Wnoncanonical-monoid-instances + + if flag(internal-interpreter) + CPP-Options: -DHAVE_INTERNAL_INTERPRETER + + -- if no dynamic system linker is available, don't try DLLs. + if flag(dynamic-system-linker) + CPP-Options: -DCAN_LOAD_DLL + + Other-Extensions: + CPP + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + DisambiguateRecordFields + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NondecreasingIndentation + RankNTypes + RecordWildCards + StandaloneDeriving + Trustworthy + TupleSections + TypeFamilies + TypeSynonymInstances + UnboxedTuples + UndecidableInstances + + Include-Dirs: . + + -- We need to set the unit id to ghc (without a version number) + -- as it's magic. + GHC-Options: -this-unit-id ghc + + c-sources: + cbits/cutils.c + cbits/genSym.c + cbits/keepCAFsForGHCi.c + + hs-source-dirs: + . + + -- we use an explicit Prelude + Default-Extensions: + NoImplicitPrelude + ,BangPatterns + ,ScopedTypeVariables + ,MonoLocalBinds + ,TypeOperators + + Exposed-Modules: + GHC + GHC.Builtin.Names + GHC.Builtin.Names.TH + GHC.Builtin.PrimOps + GHC.Builtin.PrimOps.Casts + GHC.Builtin.PrimOps.Ids + GHC.Builtin.Types + GHC.Builtin.Types.Literals + GHC.Builtin.Types.Prim + GHC.Builtin.Uniques + GHC.Builtin.Utils + GHC.ByteCode.Asm + GHC.ByteCode.InfoTable + GHC.ByteCode.Instr + GHC.ByteCode.Linker + GHC.ByteCode.Types + GHC.Cmm + GHC.Cmm.BlockId + GHC.Cmm.CallConv + GHC.Cmm.CLabel + GHC.Cmm.CommonBlockElim + GHC.Cmm.Config + GHC.Cmm.ContFlowOpt + GHC.Cmm.Dataflow + GHC.Cmm.Dataflow.Block + GHC.Cmm.Dataflow.Collections + GHC.Cmm.Dataflow.Graph + GHC.Cmm.Dataflow.Label + GHC.Cmm.DebugBlock + GHC.Cmm.Expr + GHC.Cmm.Graph + GHC.Cmm.Info + GHC.Cmm.Info.Build + GHC.Cmm.InitFini + GHC.Cmm.LayoutStack + GHC.Cmm.Lexer + GHC.Cmm.Lint + GHC.Cmm.Liveness + GHC.Cmm.MachOp + GHC.Cmm.Node + GHC.Cmm.Opt + GHC.Cmm.Parser + GHC.Cmm.Parser.Config + GHC.Cmm.Parser.Monad + GHC.Cmm.Pipeline + GHC.Cmm.ProcPoint + GHC.Cmm.Reg + GHC.Cmm.Sink + GHC.Cmm.Switch + GHC.Cmm.Switch.Implement + GHC.Cmm.ThreadSanitizer + GHC.CmmToAsm + GHC.Cmm.LRegSet + GHC.CmmToAsm.AArch64 + GHC.CmmToAsm.AArch64.CodeGen + GHC.CmmToAsm.AArch64.Cond + GHC.CmmToAsm.AArch64.Instr + GHC.CmmToAsm.AArch64.Ppr + GHC.CmmToAsm.AArch64.RegInfo + GHC.CmmToAsm.AArch64.Regs + GHC.CmmToAsm.BlockLayout + GHC.CmmToAsm.CFG + GHC.CmmToAsm.CFG.Dominators + GHC.CmmToAsm.CFG.Weight + GHC.CmmToAsm.Config + GHC.CmmToAsm.CPrim + GHC.CmmToAsm.Dwarf + GHC.CmmToAsm.Dwarf.Constants + GHC.CmmToAsm.Dwarf.Types + GHC.CmmToAsm.Format + GHC.CmmToAsm.Instr + GHC.CmmToAsm.Monad + GHC.CmmToAsm.PIC + GHC.CmmToAsm.PPC + GHC.CmmToAsm.PPC.CodeGen + GHC.CmmToAsm.PPC.Cond + GHC.CmmToAsm.PPC.Instr + GHC.CmmToAsm.PPC.Ppr + GHC.CmmToAsm.PPC.RegInfo + GHC.CmmToAsm.PPC.Regs + GHC.CmmToAsm.Ppr + GHC.CmmToAsm.Reg.Graph + GHC.CmmToAsm.Reg.Graph.Base + GHC.CmmToAsm.Reg.Graph.Coalesce + GHC.CmmToAsm.Reg.Graph.Spill + GHC.CmmToAsm.Reg.Graph.SpillClean + GHC.CmmToAsm.Reg.Graph.SpillCost + GHC.CmmToAsm.Reg.Graph.Stats + GHC.CmmToAsm.Reg.Graph.TrivColorable + GHC.CmmToAsm.Reg.Graph.X86 + GHC.CmmToAsm.Reg.Linear + GHC.CmmToAsm.Reg.Linear.AArch64 + GHC.CmmToAsm.Reg.Linear.Base + GHC.CmmToAsm.Reg.Linear.FreeRegs + GHC.CmmToAsm.Reg.Linear.JoinToTargets + GHC.CmmToAsm.Reg.Linear.PPC + GHC.CmmToAsm.Reg.Linear.StackMap + GHC.CmmToAsm.Reg.Linear.State + GHC.CmmToAsm.Reg.Linear.Stats + GHC.CmmToAsm.Reg.Linear.X86 + GHC.CmmToAsm.Reg.Linear.X86_64 + GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Target + GHC.CmmToAsm.Reg.Utils + GHC.CmmToAsm.Types + GHC.CmmToAsm.Utils + GHC.CmmToAsm.X86 + GHC.CmmToAsm.X86.CodeGen + GHC.CmmToAsm.X86.Cond + GHC.CmmToAsm.X86.Instr + GHC.CmmToAsm.X86.Ppr + GHC.CmmToAsm.X86.RegInfo + GHC.CmmToAsm.X86.Regs + GHC.CmmToC + GHC.CmmToLlvm + GHC.CmmToLlvm.Base + GHC.CmmToLlvm.CodeGen + GHC.CmmToLlvm.Config + GHC.CmmToLlvm.Data + GHC.CmmToLlvm.Mangler + GHC.CmmToLlvm.Ppr + GHC.CmmToLlvm.Regs + GHC.Cmm.Dominators + GHC.Cmm.Reducibility + GHC.Cmm.Type + GHC.Cmm.Utils + GHC.Core + GHC.Core.Class + GHC.Core.Coercion + GHC.Core.Coercion.Axiom + GHC.Core.Coercion.Opt + GHC.Core.ConLike + GHC.Core.DataCon + GHC.Core.FamInstEnv + GHC.Core.FVs + GHC.Core.InstEnv + GHC.Core.Lint + GHC.Core.Lint.Interactive + GHC.Core.LateCC + GHC.Core.Make + GHC.Core.Map.Expr + GHC.Core.Map.Type + GHC.Core.Multiplicity + GHC.Core.Opt.Arity + GHC.Core.Opt.CallArity + GHC.Core.Opt.CallerCC + GHC.Core.Opt.ConstantFold + GHC.Core.Opt.CprAnal + GHC.Core.Opt.CSE + GHC.Core.Opt.DmdAnal + GHC.Core.Opt.Exitify + GHC.Core.Opt.FloatIn + GHC.Core.Opt.FloatOut + GHC.Core.Opt.LiberateCase + GHC.Core.Opt.Monad + GHC.Core.Opt.OccurAnal + GHC.Core.Opt.Pipeline + GHC.Core.Opt.Pipeline.Types + GHC.Core.Opt.SetLevels + GHC.Core.Opt.Simplify + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Iteration + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.SpecConstr + GHC.Core.Opt.Specialise + GHC.Core.Opt.StaticArgs + GHC.Core.Opt.Stats + GHC.Core.Opt.WorkWrap + GHC.Core.Opt.WorkWrap.Utils + GHC.Core.PatSyn + GHC.Core.Ppr + GHC.Types.TyThing.Ppr + GHC.Core.Predicate + GHC.Core.Reduction + GHC.Core.Rules + GHC.Core.Rules.Config + GHC.Core.Seq + GHC.Core.SimpleOpt + GHC.Core.Stats + GHC.Core.Subst + GHC.Core.Tidy + GHC.CoreToIface + GHC.CoreToStg + GHC.CoreToStg.Prep + GHC.Core.TyCo.FVs + GHC.Core.TyCo.Compare + GHC.Core.TyCon + GHC.Core.TyCon.Env + GHC.Core.TyCon.RecWalk + GHC.Core.TyCon.Set + GHC.Core.TyCo.Ppr + GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst + GHC.Core.TyCo.Tidy + GHC.Core.Type + GHC.Core.RoughMap + GHC.Core.Unfold + GHC.Core.Unfold.Make + GHC.Core.Unify + GHC.Core.UsageEnv + GHC.Core.Utils + GHC.Data.Bag + GHC.Data.Bitmap + GHC.Data.Bool + GHC.Data.BooleanFormula + GHC.Data.EnumSet + GHC.Data.FastMutInt + GHC.Data.FastString + GHC.Data.FastString.Env + GHC.Data.FiniteMap + GHC.Data.Graph.Base + GHC.Data.Graph.Color + GHC.Data.Graph.Collapse + GHC.Data.Graph.Directed + GHC.Data.Graph.Inductive.Graph + GHC.Data.Graph.Inductive.PatriciaTree + GHC.Data.Graph.Ops + GHC.Data.Graph.Ppr + GHC.Data.Graph.UnVar + GHC.Data.IOEnv + GHC.Data.List.Infinite + GHC.Data.List.SetOps + GHC.Data.Maybe + GHC.Data.OrdList + GHC.Data.Pair + GHC.Data.SmallArray + GHC.Data.Stream + GHC.Data.Strict + GHC.Data.StringBuffer + GHC.Data.TrieMap + GHC.Data.Unboxed + GHC.Data.UnionFind + GHC.Driver.Backend + GHC.Driver.Backend.Internal + GHC.Driver.Backpack + GHC.Driver.Backpack.Syntax + GHC.Driver.CmdLine + GHC.Driver.CodeOutput + GHC.Driver.Config + GHC.Driver.Config.Cmm + GHC.Driver.Config.Cmm.Parser + GHC.Driver.Config.CmmToAsm + GHC.Driver.Config.CmmToLlvm + GHC.Driver.Config.Core.Lint + GHC.Driver.Config.Core.Lint.Interactive + GHC.Driver.Config.Core.Opt.Arity + GHC.Driver.Config.Core.Opt.LiberateCase + GHC.Driver.Config.Core.Opt.Simplify + GHC.Driver.Config.Core.Opt.WorkWrap + GHC.Driver.Config.Core.Rules + GHC.Driver.Config.CoreToStg + GHC.Driver.Config.CoreToStg.Prep + GHC.Driver.Config.Diagnostic + GHC.Driver.Config.Finder + GHC.Driver.Config.HsToCore + GHC.Driver.Config.HsToCore.Ticks + GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Linker + GHC.Driver.Config.Logger + GHC.Driver.Config.Parser + GHC.Driver.Config.Stg.Debug + GHC.Driver.Config.Stg.Lift + GHC.Driver.Config.Stg.Pipeline + GHC.Driver.Config.Stg.Ppr + GHC.Driver.Config.StgToCmm + GHC.Driver.Config.Tidy + GHC.Driver.Config.StgToJS + GHC.Driver.Env + GHC.Driver.Env.KnotVars + GHC.Driver.Env.Types + GHC.Driver.Errors + GHC.Driver.Errors.Ppr + GHC.Driver.Errors.Types + GHC.Driver.Flags + GHC.Driver.GenerateCgIPEStub + GHC.Driver.Hooks + GHC.Driver.LlvmConfigCache + GHC.Driver.Main + GHC.Driver.Make + GHC.Driver.MakeFile + GHC.Driver.Monad + GHC.Driver.Phases + GHC.Driver.Pipeline + GHC.Driver.Pipeline.Execute + GHC.Driver.Pipeline.LogQueue + GHC.Driver.Pipeline.Phases + GHC.Driver.Pipeline.Monad + GHC.Driver.Plugins + GHC.Driver.Plugins.External + GHC.Driver.Ppr + GHC.Driver.Session + GHC.Hs + GHC.Hs.Binds + GHC.Hs.Decls + GHC.Hs.Doc + GHC.Hs.DocString + GHC.Hs.Dump + GHC.Hs.Expr + GHC.Hs.Syn.Type + GHC.Hs.Extension + GHC.Hs.ImpExp + GHC.Hs.Instances + GHC.Hs.Lit + GHC.Hs.Pat + GHC.Hs.Stats + GHC.HsToCore + GHC.HsToCore.Arrows + GHC.HsToCore.Binds + GHC.HsToCore.Breakpoints + GHC.HsToCore.Coverage + GHC.HsToCore.Docs + GHC.HsToCore.Errors.Ppr + GHC.HsToCore.Errors.Types + GHC.HsToCore.Expr + GHC.HsToCore.Foreign.C + GHC.HsToCore.Foreign.Call + GHC.HsToCore.Foreign.Decl + GHC.HsToCore.Foreign.JavaScript + GHC.HsToCore.Foreign.Prim + GHC.HsToCore.Foreign.Utils + GHC.HsToCore.GuardedRHSs + GHC.HsToCore.ListComp + GHC.HsToCore.Match + GHC.HsToCore.Match.Constructor + GHC.HsToCore.Match.Literal + GHC.HsToCore.Monad + GHC.HsToCore.Pmc + GHC.HsToCore.Pmc.Check + GHC.HsToCore.Pmc.Desugar + GHC.HsToCore.Pmc.Ppr + GHC.HsToCore.Pmc.Solver + GHC.HsToCore.Pmc.Solver.Types + GHC.HsToCore.Pmc.Types + GHC.HsToCore.Pmc.Utils + GHC.HsToCore.Quote + GHC.HsToCore.Ticks + GHC.HsToCore.Types + GHC.HsToCore.Usage + GHC.HsToCore.Utils + GHC.Hs.Type + GHC.Hs.Utils + GHC.Iface.Binary + GHC.Iface.Env + GHC.Iface.Errors + GHC.Iface.Ext.Ast + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Fields + GHC.Iface.Ext.Types + GHC.Iface.Ext.Utils + GHC.Iface.Load + GHC.Iface.Make + GHC.Iface.Recomp + GHC.Iface.Recomp.Binary + GHC.Iface.Recomp.Flags + GHC.Iface.Rename + GHC.Iface.Syntax + GHC.Iface.Tidy + GHC.Iface.Tidy.StaticPtrTable + GHC.IfaceToCore + GHC.Iface.Type + GHC.JS.Make + GHC.JS.Ppr + GHC.JS.Syntax + GHC.JS.Transform + GHC.Linker + GHC.Linker.Config + GHC.Linker.Dynamic + GHC.Linker.ExtraObj + GHC.Linker.Loader + GHC.Linker.MacOS + GHC.Linker.Static + GHC.Linker.Static.Utils + GHC.Linker.Types + GHC.Linker.Unit + GHC.Linker.Windows + GHC.Llvm + GHC.Llvm.MetaData + GHC.Llvm.Ppr + GHC.Llvm.Syntax + GHC.Llvm.Types + GHC.Parser + GHC.Parser.Annotation + GHC.Parser.CharClass + GHC.Parser.Errors.Basic + GHC.Parser.Errors.Ppr + GHC.Parser.Errors.Types + GHC.Parser.Header + GHC.Parser.Lexer + GHC.Parser.HaddockLex + GHC.Parser.PostProcess + GHC.Parser.PostProcess.Haddock + GHC.Parser.Types + GHC.Parser.Utils + GHC.Platform + GHC.Platform.ARM + GHC.Platform.AArch64 + GHC.Platform.Constants + GHC.Platform.NoRegs + GHC.Platform.PPC + GHC.Platform.Profile + GHC.Platform.Reg + GHC.Platform.Reg.Class + GHC.Platform.Regs + GHC.Platform.RISCV64 + GHC.Platform.LoongArch64 + GHC.Platform.S390X + GHC.Platform.Wasm32 + GHC.Platform.Ways + GHC.Platform.X86 + GHC.Platform.X86_64 + GHC.Plugins + GHC.Prelude + GHC.Prelude.Basic + GHC.Rename.Bind + GHC.Rename.Doc + GHC.Rename.Env + GHC.Rename.Expr + GHC.Rename.Fixity + GHC.Rename.HsType + GHC.Rename.Module + GHC.Rename.Names + GHC.Rename.Pat + GHC.Rename.Splice + GHC.Rename.Unbound + GHC.Rename.Utils + GHC.Runtime.Context + GHC.Runtime.Debugger + GHC.Runtime.Eval + GHC.Runtime.Eval.Types + GHC.Runtime.Heap.Inspect + GHC.Runtime.Heap.Layout + GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.Types + GHC.Runtime.Loader + GHC.Settings + GHC.Settings.Config + GHC.Settings.Constants + GHC.Settings.IO + GHC.Stg.BcPrep + GHC.Stg.CSE + GHC.Stg.Debug + GHC.Stg.FVs + GHC.Stg.Lift + GHC.Stg.Lift.Analysis + GHC.Stg.Lift.Config + GHC.Stg.Lift.Monad + GHC.Stg.Lint + GHC.Stg.InferTags + GHC.Stg.InferTags.Rewrite + GHC.Stg.InferTags.TagSig + GHC.Stg.InferTags.Types + GHC.Stg.Pipeline + GHC.Stg.Stats + GHC.Stg.Subst + GHC.Stg.Syntax + GHC.Stg.Utils + GHC.StgToByteCode + GHC.StgToCmm + GHC.StgToCmm.ArgRep + GHC.StgToCmm.Bind + GHC.StgToCmm.CgUtils + GHC.StgToCmm.Closure + GHC.StgToCmm.Config + GHC.StgToCmm.DataCon + GHC.StgToCmm.Env + GHC.StgToCmm.Expr + GHC.StgToCmm.ExtCode + GHC.StgToCmm.Foreign + GHC.StgToCmm.Heap + GHC.StgToCmm.Hpc + GHC.StgToCmm.InfoTableProv + GHC.StgToCmm.Layout + GHC.StgToCmm.Lit + GHC.StgToCmm.Monad + GHC.StgToCmm.Prim + GHC.StgToCmm.Prof + GHC.StgToCmm.Sequel + GHC.StgToCmm.TagCheck + GHC.StgToCmm.Ticky + GHC.StgToCmm.Types + GHC.StgToCmm.Utils + GHC.StgToJS + GHC.StgToJS.Apply + GHC.StgToJS.Arg + GHC.StgToJS.Closure + GHC.StgToJS.CodeGen + GHC.StgToJS.CoreUtils + GHC.StgToJS.DataCon + GHC.StgToJS.Deps + GHC.StgToJS.Expr + GHC.StgToJS.ExprCtx + GHC.StgToJS.FFI + GHC.StgToJS.Heap + GHC.StgToJS.Ids + GHC.StgToJS.Literal + GHC.StgToJS.Monad + GHC.StgToJS.Object + GHC.StgToJS.Prim + GHC.StgToJS.Profiling + GHC.StgToJS.Printer + GHC.StgToJS.Regs + GHC.StgToJS.Rts.Types + GHC.StgToJS.Rts.Rts + GHC.StgToJS.Sinker + GHC.StgToJS.Stack + GHC.StgToJS.StaticPtr + GHC.StgToJS.StgUtils + GHC.StgToJS.Symbols + GHC.StgToJS.Types + GHC.StgToJS.Utils + GHC.StgToJS.Linker.Linker + GHC.StgToJS.Linker.Types + GHC.StgToJS.Linker.Utils + GHC.Stg.Unarise + GHC.SysTools + GHC.SysTools.Ar + GHC.SysTools.BaseDir + GHC.SysTools.Cpp + GHC.SysTools.Elf + GHC.SysTools.Info + GHC.SysTools.Process + GHC.SysTools.Tasks + GHC.SysTools.Terminal + GHC.Tc.Deriv + GHC.Tc.Deriv.Functor + GHC.Tc.Deriv.Generate + GHC.Tc.Deriv.Generics + GHC.Tc.Deriv.Infer + GHC.Tc.Deriv.Utils + GHC.Tc.Errors + GHC.Tc.Errors.Hole + GHC.Tc.Errors.Hole.FitTypes + GHC.Tc.Errors.Ppr + GHC.Tc.Errors.Types + GHC.Tc.Gen.Annotation + GHC.Tc.Gen.App + GHC.Tc.Gen.Arrow + GHC.Tc.Gen.Bind + GHC.Tc.Gen.Default + GHC.Tc.Gen.Export + GHC.Tc.Gen.Expr + GHC.Tc.Gen.Foreign + GHC.Tc.Gen.Head + GHC.Tc.Gen.HsType + GHC.Tc.Gen.Match + GHC.Tc.Gen.Pat + GHC.Tc.Gen.Rule + GHC.Tc.Gen.Sig + GHC.Tc.Gen.Splice + GHC.Tc.Instance.Class + GHC.Tc.Instance.Family + GHC.Tc.Instance.FunDeps + GHC.Tc.Instance.Typeable + GHC.Tc.Module + GHC.Tc.Plugin + GHC.Tc.Solver + GHC.Tc.Solver.Canonical + GHC.Tc.Solver.Rewrite + GHC.Tc.Solver.InertSet + GHC.Tc.Solver.Interact + GHC.Tc.Solver.Monad + GHC.Tc.Solver.Types + GHC.Tc.TyCl + GHC.Tc.TyCl.Build + GHC.Tc.TyCl.Class + GHC.Tc.TyCl.Instance + GHC.Tc.TyCl.PatSyn + GHC.Tc.TyCl.Utils + GHC.Tc.Types + GHC.Tc.Types.Constraint + GHC.Tc.Types.Evidence + GHC.Tc.Types.EvTerm + GHC.Tc.Types.Origin + GHC.Tc.Types.Rank + GHC.Tc.Utils.Backpack + GHC.Tc.Utils.Concrete + GHC.Tc.Utils.Env + GHC.Tc.Utils.Instantiate + GHC.Tc.Utils.Monad + GHC.Tc.Utils.TcMType + GHC.Tc.Utils.TcType + GHC.Tc.Utils.Unify + GHC.Tc.Utils.Zonk + GHC.Tc.Validity + GHC.ThToHs + GHC.Types.Annotations + GHC.Types.Avail + GHC.Types.Basic + GHC.Types.BreakInfo + GHC.Types.CompleteMatch + GHC.Types.CostCentre + GHC.Types.CostCentre.State + GHC.Types.Cpr + GHC.Types.Demand + GHC.Types.Error + GHC.Types.Error.Codes + GHC.Types.FieldLabel + GHC.Types.Fixity + GHC.Types.Fixity.Env + GHC.Types.ForeignCall + GHC.Types.ForeignStubs + GHC.Types.Hint + GHC.Types.Hint.Ppr + GHC.Types.HpcInfo + GHC.Types.Id + GHC.Types.IPE + GHC.Types.Id.Info + GHC.Types.Id.Make + GHC.Types.Literal + GHC.Types.Meta + GHC.Types.Name + GHC.Types.Name.Cache + GHC.Types.Name.Env + GHC.Types.Name.Occurrence + GHC.Types.Name.Reader + GHC.Types.Name.Set + GHC.Types.Name.Shape + GHC.Types.Name.Ppr + GHC.Types.PkgQual + GHC.Types.ProfAuto + GHC.Types.RepType + GHC.Types.SafeHaskell + GHC.Types.SourceError + GHC.Types.SourceFile + GHC.Types.SourceText + GHC.Types.SrcLoc + GHC.Types.Target + GHC.Types.Tickish + GHC.Types.TypeEnv + GHC.Types.TyThing + GHC.Types.Unique + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.FM + GHC.Types.Unique.Map + GHC.Types.Unique.MemoFun + GHC.Types.Unique.SDFM + GHC.Types.Unique.Set + GHC.Types.Unique.Supply + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set + GHC.Unit + GHC.Unit.Env + GHC.Unit.External + GHC.Unit.Finder + GHC.Unit.Finder.Types + GHC.Unit.Home + GHC.Unit.Home.ModInfo + GHC.Unit.Info + GHC.Unit.Module + GHC.Unit.Module.Deps + GHC.Unit.Module.Env + GHC.Unit.Module.Graph + GHC.Unit.Module.Imported + GHC.Unit.Module.Location + GHC.Unit.Module.ModDetails + GHC.Unit.Module.ModGuts + GHC.Unit.Module.ModIface + GHC.Unit.Module.WholeCoreBindings + GHC.Unit.Module.ModSummary + GHC.Unit.Module.Status + GHC.Unit.Module.Warnings + GHC.Unit.Parser + GHC.Unit.Ppr + GHC.Unit.State + GHC.Unit.Types + GHC.Utils.Asm + GHC.Utils.Binary + GHC.Utils.Binary.Typeable + GHC.Utils.BufHandle + GHC.Utils.CliOption + GHC.Utils.Constants + GHC.Utils.Error + GHC.Utils.Exception + GHC.Utils.Fingerprint + GHC.Utils.FV + GHC.Utils.GlobalVars + GHC.Utils.IO.Unsafe + GHC.Utils.Json + GHC.Utils.Lexeme + GHC.Utils.Logger + GHC.Utils.Misc + GHC.Utils.Monad + GHC.Utils.Monad.State.Strict + GHC.Utils.Outputable + GHC.Utils.Panic + GHC.Utils.Panic.Plain + GHC.Utils.Ppr + GHC.Utils.Ppr.Colour + GHC.Utils.TmpFs + GHC.Utils.Trace + GHC.Wasm.ControlFlow + GHC.Wasm.ControlFlow.FromCmm + GHC.CmmToAsm.Wasm + GHC.CmmToAsm.Wasm.Asm + GHC.CmmToAsm.Wasm.FromCmm + GHC.CmmToAsm.Wasm.Types + GHC.CmmToAsm.Wasm.Utils + + Language.Haskell.Syntax + Language.Haskell.Syntax.Basic + Language.Haskell.Syntax.Binds + Language.Haskell.Syntax.Concrete + Language.Haskell.Syntax.Decls + Language.Haskell.Syntax.Expr + Language.Haskell.Syntax.Extension + Language.Haskell.Syntax.ImpExp + Language.Haskell.Syntax.Lit + Language.Haskell.Syntax.Module.Name + Language.Haskell.Syntax.Pat + Language.Haskell.Syntax.Type + + autogen-modules: GHC.Platform.Constants + GHC.Settings.Config + + reexported-modules: + GHC.Platform.ArchOS + , GHC.Platform.Host diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,8 +1,8 @@ -cabal-version: 3.0 +cabal-version: 2.0 build-type: Simple name: ghc-lib-parser -version: 9.4.8.20231111 -license: BSD-3-Clause +version: 9.6.1.20230312 +license: BSD3 license-file: LICENSE category: Development author: The GHC Team and Digital Asset @@ -17,6 +17,13 @@ llvm-targets llvm-passes extra-source-files: + ghc/ghc-bin.cabal + libraries/template-haskell/template-haskell.cabal + libraries/ghc-heap/ghc-heap.cabal + libraries/ghc-boot-th/ghc-boot-th.cabal + libraries/ghc-boot/ghc-boot.cabal + libraries/ghci/ghci.cabal + compiler/ghc.cabal ghc-lib/stage0/rts/build/include/ghcautoconf.h ghc-lib/stage0/rts/build/include/ghcplatform.h ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -79,18 +86,18 @@ else build-depends: Win32 build-depends: - base >= 4.15 && < 4.18, - ghc-prim > 0.2 && < 0.10, - containers >= 0.5 && < 0.7, - bytestring >= 0.10 && < 0.12, + base >= 4.16.1 && < 4.19, + ghc-prim > 0.2 && < 0.11, + bytestring >= 0.11.3 && < 0.12, time >= 1.4 && < 1.13, exceptions == 0.10.*, parsec, + containers >= 0.5 && < 0.7, binary == 0.8.*, filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, - deepseq >= 1.4 && < 1.6, + deepseq >= 1.4 && < 1.5, pretty == 1.1.*, transformers >= 0.5 && < 0.7, process >= 1 && < 1.7 @@ -130,17 +137,13 @@ UndecidableInstances default-extensions: BangPatterns + ImplicitPrelude MonoLocalBinds NoImplicitPrelude ScopedTypeVariables TypeOperators - if impl(ghc >= 9.2.2) - cmm-sources: - libraries/ghc-heap/cbits/HeapPrim.cmm - else - c-sources: - libraries/ghc-heap/cbits/HeapPrim.cmm c-sources: + libraries/ghc-heap/cbits/HeapPrim.cmm compiler/cbits/genSym.c compiler/cbits/cutils.c compiler/cbits/keepCAFsForGHCi.c @@ -175,9 +178,11 @@ GHC.Cmm.Expr GHC.Cmm.MachOp GHC.Cmm.Node + GHC.Cmm.Reg GHC.Cmm.Switch GHC.Cmm.Type GHC.CmmToAsm.CFG.Weight + GHC.CmmToLlvm.Config GHC.Core GHC.Core.Class GHC.Core.Coercion @@ -189,6 +194,7 @@ GHC.Core.FamInstEnv GHC.Core.InstEnv GHC.Core.Lint + GHC.Core.Lint.Interactive GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type @@ -198,17 +204,26 @@ GHC.Core.Opt.ConstantFold GHC.Core.Opt.Monad GHC.Core.Opt.OccurAnal + GHC.Core.Opt.Pipeline.Types + GHC.Core.Opt.Simplify + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Iteration + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.Stats GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate GHC.Core.Reduction GHC.Core.RoughMap GHC.Core.Rules + GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats GHC.Core.Subst GHC.Core.Tidy + GHC.Core.TyCo.Compare GHC.Core.TyCo.FVs GHC.Core.TyCo.Ppr GHC.Core.TyCo.Rep @@ -235,6 +250,7 @@ GHC.Data.Graph.Directed GHC.Data.Graph.UnVar GHC.Data.IOEnv + GHC.Data.List.Infinite GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList @@ -246,10 +262,13 @@ GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap + GHC.Data.Unboxed GHC.Driver.Backend + GHC.Driver.Backend.Internal GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine GHC.Driver.Config + GHC.Driver.Config.Core.Lint GHC.Driver.Config.Diagnostic GHC.Driver.Config.Logger GHC.Driver.Config.Parser @@ -261,11 +280,13 @@ GHC.Driver.Errors.Types GHC.Driver.Flags GHC.Driver.Hooks + GHC.Driver.LlvmConfigCache GHC.Driver.Monad GHC.Driver.Phases GHC.Driver.Pipeline.Monad GHC.Driver.Pipeline.Phases GHC.Driver.Plugins + GHC.Driver.Plugins.External GHC.Driver.Ppr GHC.Driver.Session GHC.Exts.Heap @@ -330,6 +351,7 @@ GHC.Platform.ARM GHC.Platform.ArchOS GHC.Platform.Constants + GHC.Platform.LoongArch64 GHC.Platform.NoRegs GHC.Platform.PPC GHC.Platform.Profile @@ -338,10 +360,12 @@ GHC.Platform.Reg.Class GHC.Platform.Regs GHC.Platform.S390X + GHC.Platform.Wasm32 GHC.Platform.Ways GHC.Platform.X86 GHC.Platform.X86_64 GHC.Prelude + GHC.Prelude.Basic GHC.Runtime.Context GHC.Runtime.Eval.Types GHC.Runtime.Heap.Layout @@ -351,6 +375,7 @@ GHC.Settings GHC.Settings.Config GHC.Settings.Constants + GHC.Settings.Utils GHC.Stg.InferTags.TagSig GHC.Stg.Syntax GHC.StgToCmm.Config @@ -378,6 +403,7 @@ GHC.Types.Cpr GHC.Types.Demand GHC.Types.Error + GHC.Types.Error.Codes GHC.Types.FieldLabel GHC.Types.Fixity GHC.Types.Fixity.Env @@ -400,6 +426,7 @@ GHC.Types.Name.Reader GHC.Types.Name.Set GHC.Types.PkgQual + GHC.Types.ProfAuto GHC.Types.RepType GHC.Types.SafeHaskell GHC.Types.SourceError @@ -440,9 +467,9 @@ GHC.Unit.Module.ModGuts GHC.Unit.Module.ModIface GHC.Unit.Module.ModSummary - GHC.Unit.Module.Name GHC.Unit.Module.Status GHC.Unit.Module.Warnings + GHC.Unit.Module.WholeCoreBindings GHC.Unit.Parser GHC.Unit.Ppr GHC.Unit.State @@ -453,6 +480,7 @@ GHC.Utils.CliOption GHC.Utils.Constants GHC.Utils.Encoding + GHC.Utils.Encoding.UTF8 GHC.Utils.Error GHC.Utils.Exception GHC.Utils.FV @@ -481,11 +509,15 @@ GHCi.ResolvedBCO GHCi.TH.Binary Language.Haskell.Syntax + Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds + Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension + Language.Haskell.Syntax.ImpExp Language.Haskell.Syntax.Lit + Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Type Language.Haskell.TH diff --git a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs --- a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs @@ -7,7 +7,7 @@ , cStage ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Version @@ -21,7 +21,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "9.4.5" +cBooterVersion = "9.2.5" cStage :: String cStage = show (1 :: Int) diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl @@ -234,6 +234,9 @@ primOpCanFail AtomicModifyMutVar2Op = True primOpCanFail AtomicModifyMutVar_Op = True primOpCanFail RaiseOp = True +primOpCanFail RaiseUnderflowOp = True +primOpCanFail RaiseOverflowOp = True +primOpCanFail RaiseDivZeroOp = True primOpCanFail ReallyUnsafePtrEqualityOp = True primOpCanFail (VecInsertOp _ _ _) = True primOpCanFail (VecDivOp _ _ _) = True diff --git a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl @@ -61,6 +61,9 @@ primOpCodeSize AddrToIntOp = 0 primOpCodeSize IntToAddrOp = 0 primOpCodeSize WriteMutVarOp = primOpCodeSizeForeignCall +primOpCodeSize RaiseUnderflowOp = primOpCodeSizeForeignCall +primOpCodeSize RaiseOverflowOp = primOpCodeSizeForeignCall +primOpCodeSize RaiseDivZeroOp = primOpCodeSizeForeignCall primOpCodeSize TouchOp = 0 primOpCodeSize ParOp = primOpCodeSizeForeignCall primOpCodeSize SparkOp = primOpCodeSizeForeignCall diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -563,11 +563,17 @@ | CasMutVarOp | CatchOp | RaiseOp + | RaiseUnderflowOp + | RaiseOverflowOp + | RaiseDivZeroOp | RaiseIOOp | MaskAsyncExceptionsOp | MaskUninterruptibleOp | UnmaskAsyncExceptionsOp | MaskStatus + | NewPromptTagOp + | PromptOp + | Control0Op | AtomicallyOp | RetryOp | CatchRetryOp @@ -598,7 +604,9 @@ | LabelThreadOp | IsCurrentThreadBoundOp | NoDuplicateOp + | GetThreadLabelOp | ThreadStatusOp + | ListThreadsOp | MkWeakOp | MkWeakNoFinalizerOp | AddCFinalizerToWeakOp diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -3,25 +3,25 @@ , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n the high and low bits of the double-word result. isHighNeeded is a cheap way\n to test if the high word is a sign-extension of the low word (isHighNeeded =\n 0#) or not (isHighNeeded = 1#).") , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n signed integer multiply might contain useful information. Return\n zero only if you are completely sure that no overflow can occur.\n On a 32-bit platform, the recommended implementation is to do a\n 32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n (result[31] >>signed 31). If this is zero, meaning that the\n upper word is merely a sign extension of the lower one, no\n overflow can occur.\n\n On a 64-bit platform it is not always possible to\n acquire the top 64 bits of the result. Therefore, a recommended\n implementation is to take the absolute value of both operands, and\n return 0 iff bits[63:31] of them are zero, since that means that their\n magnitudes fit within 31 bits, so the magnitude of the product must fit\n into 62 bits.\n\n If in doubt, return non-zero, but do make an effort to create the\n correct answer for small args, since otherwise the performance of\n @(*) :: Integer -> Integer -> Integer@ will be poor.\n ") , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n zero.\n ") - , ("remInt#","Satisfies @(quotInt\\# x y) *\\# y +\\# (remInt\\# x y) == x@. The\n behavior is undefined if the second argument is zero.\n ") + , ("remInt#","Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The\n behavior is undefined if the second argument is zero.\n ") , ("quotRemInt#","Rounds towards zero.") , ("andI#","Bitwise \"and\".") , ("orI#","Bitwise \"or\".") , ("xorI#","Bitwise \"xor\".") , ("notI#","Bitwise \"not\", also known as the binary complement.") - , ("negateInt#","Unary negation.\n Since the negative @Int#@ range extends one further than the\n positive range, @negateInt#@ of the most negative number is an\n identity operation. This way, @negateInt#@ is always its own inverse.") - , ("addIntC#","Add signed integers reporting overflow.\n First member of result is the sum truncated to an @Int#@;\n second member is zero if the true sum fits in an @Int#@,\n nonzero if overflow occurred (the sum is either too large\n or too small to fit in an @Int#@).") - , ("subIntC#","Subtract signed integers reporting overflow.\n First member of result is the difference truncated to an @Int#@;\n second member is zero if the true difference fits in an @Int#@,\n nonzero if overflow occurred (the difference is either too large\n or too small to fit in an @Int#@).") - , ("int2Float#","Convert an @Int#@ to the corresponding @Float#@ with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @int2Float# 1# == 1.0#@") - , ("int2Double#","Convert an @Int#@ to the corresponding @Double#@ with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @int2Double# 1# == 1.0##@") - , ("word2Float#","Convert an @Word#@ to the corresponding @Float#@ with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @word2Float# 1## == 1.0#@") - , ("word2Double#","Convert an @Word#@ to the corresponding @Double#@ with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @word2Double# 1## == 1.0##@") + , ("negateInt#","Unary negation.\n Since the negative 'Int#' range extends one further than the\n positive range, 'negateInt#' of the most negative number is an\n identity operation. This way, 'negateInt#' is always its own inverse.") + , ("addIntC#","Add signed integers reporting overflow.\n First member of result is the sum truncated to an 'Int#';\n second member is zero if the true sum fits in an 'Int#',\n nonzero if overflow occurred (the sum is either too large\n or too small to fit in an 'Int#').") + , ("subIntC#","Subtract signed integers reporting overflow.\n First member of result is the difference truncated to an 'Int#';\n second member is zero if the true difference fits in an 'Int#',\n nonzero if overflow occurred (the difference is either too large\n or too small to fit in an 'Int#').") + , ("int2Float#","Convert an 'Int#' to the corresponding 'Float#' with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @'int2Float#' 1# == 1.0#@") + , ("int2Double#","Convert an 'Int#' to the corresponding 'Double#' with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @'int2Double#' 1# == 1.0##@") + , ("word2Float#","Convert an 'Word#' to the corresponding 'Float#' with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @'word2Float#' 1## == 1.0#@") + , ("word2Double#","Convert an 'Word#' to the corresponding 'Double#' with the same\n integral value (up to truncation due to floating-point precision). e.g.\n @'word2Double#' 1## == 1.0##@") , ("uncheckedIShiftL#","Shift left. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") , ("uncheckedIShiftRA#","Shift right arithmetic. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") , ("uncheckedIShiftRL#","Shift right logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") - , ("addWordC#","Add unsigned integers reporting overflow.\n The first element of the pair is the result. The second element is\n the carry flag, which is nonzero on overflow. See also @plusWord2#@.") + , ("addWordC#","Add unsigned integers reporting overflow.\n The first element of the pair is the result. The second element is\n the carry flag, which is nonzero on overflow. See also 'plusWord2#'.") , ("subWordC#","Subtract unsigned integers reporting overflow.\n The first element of the pair is the result. The second element is\n the carry flag, which is nonzero on overflow.") - , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n component of the returned pair and the low part in the second\n component of the pair. See also @addWordC#@.") + , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n component of the returned pair and the low part in the second\n component of the pair. See also 'addWordC#'.") , ("quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n Requires that high word < divisor.") , ("uncheckedShiftL#","Shift left logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") , ("uncheckedShiftRL#","Shift right logical. Result undefined if shift amount is not\n in the range 0 to word size - 1 inclusive.") @@ -59,12 +59,12 @@ , ("bitReverse32#","Reverse the order of the bits in a 32-bit word.") , ("bitReverse64#","Reverse the order of the bits in a 64-bit word.") , ("bitReverse#","Reverse the order of the bits in a word.") - , ("double2Int#","Truncates a @Double#@ value to the nearest @Int#@.\n Results are undefined if the truncation if truncation yields\n a value outside the range of @Int#@.") + , ("double2Int#","Truncates a 'Double#' value to the nearest 'Int#'.\n Results are undefined if the truncation if truncation yields\n a value outside the range of 'Int#'.") , ("**##","Exponentiation.") , ("decodeDouble_2Int#","Convert to integer.\n First component of the result is -1 or 1, indicating the sign of the\n mantissa. The next two are the high and low 32 bits of the mantissa\n respectively, and the last is the exponent.") - , ("decodeDouble_Int64#","Decode @Double\\#@ into mantissa and base-2 exponent.") - , ("float2Int#","Truncates a @Float#@ value to the nearest @Int#@.\n Results are undefined if the truncation if truncation yields\n a value outside the range of @Int#@.") - , ("decodeFloat_Int#","Convert to integers.\n First @Int\\#@ in result is the mantissa; second is the exponent.") + , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.") + , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n Results are undefined if the truncation if truncation yields\n a value outside the range of 'Int#'.") + , ("decodeFloat_Int#","Convert to integers.\n First 'Int#' in result is the mantissa; second is the exponent.") , ("newArray#","Create a new mutable array with the specified number of elements,\n in the specified state thread,\n with each element containing the specified initial value.") , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.") , ("writeArray#","Write to specified index of mutable array.") @@ -79,9 +79,9 @@ , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("freezeArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("thawArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") - , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a boxed value makes this function harder\n to use correctly than @casIntArray\\#@. All of the difficulties\n of using @reallyUnsafePtrEquality\\#@ correctly apply to\n @casArray\\#@ as well.\n ") + , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a boxed value makes this function harder\n to use correctly than 'casIntArray#'. All of the difficulties\n of using 'reallyUnsafePtrEquality#' correctly apply to\n 'casArray#' as well.\n ") , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n in the specified state thread,\n with each element containing the specified initial value.") - , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @getSizeofSmallMutableArray\\#@.") + , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by 'getSizeofSmallMutableArray#'.") , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.") , ("writeSmallArray#","Write to specified index of mutable array.") , ("sizeofSmallArray#","Return the number of elements in the array.") @@ -96,18 +96,18 @@ , ("cloneSmallMutableArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("freezeSmallArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("thawSmallArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") - , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n See the documentation of @casArray\\#@.") - , ("ByteArray#","\n A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n which is not scanned for pointers during garbage collection.\n\n It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n Freezing is essentially a no-op, as MutableByteArray# and ByteArray# share the same heap structure under the hood.\n\n The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n like Text, Primitive Vector, Unboxed Array, and ShortByteString.\n \n Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n \n The representation on the heap of a Byte Array is:\n \n > +------------+-----------------+-----------------------+\n > | | | |\n > | HEADER | SIZE (in bytes) | PAYLOAD |\n > | | | |\n > +------------+-----------------+-----------------------+\n \n To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n \n Alternatively, enabling the UnliftedFFITypes extension\n allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n") - , ("MutableByteArray#"," A mutable ByteAray#. It can be created in three ways:\n\n * 'newByteArray#': Create an unpinned array.\n * 'newPinnedByteArray#': This will create a pinned array,\n * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n because no garbage collection happens during these unsafe calls\n (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function\n for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n") + , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n See the documentation of 'casArray#'.") + , ("ByteArray#","\n A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n which is not scanned for pointers during garbage collection.\n\n It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.\n\n The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.\n\n Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n\n The representation on the heap of a Byte Array is:\n\n > +------------+-----------------+-----------------------+\n > | | | |\n > | HEADER | SIZE (in bytes) | PAYLOAD |\n > | | | |\n > +------------+-----------------+-----------------------+\n\n To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n\n Alternatively, enabling the @UnliftedFFITypes@ extension\n allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n") + , ("MutableByteArray#"," A mutable 'ByteAray#'. It can be created in three ways:\n\n * 'newByteArray#': Create an unpinned array.\n * 'newPinnedByteArray#': This will create a pinned array,\n * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n because no garbage collection happens during these unsafe calls\n (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function\n for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n") , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n the specified state thread. The size of the memory underlying the\n array will be rounded up to the platform's word size.") , ("newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.") , ("newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n alignment, which must be a power of two.") - , ("isMutableByteArrayPinned#","Determine whether a @MutableByteArray\\#@ is guaranteed not to move\n during GC.") - , ("isByteArrayPinned#","Determine whether a @ByteArray\\#@ is guaranteed not to move during GC.") + , ("isMutableByteArrayPinned#","Determine whether a 'MutableByteArray#' is guaranteed not to move\n during GC.") + , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.") , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") , ("mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") - , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @getSizeofMutableByteArray\\#@.") - , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n The returned @MutableByteArray\\#@ is either the original\n @MutableByteArray\\#@ resized in-place or, if not possible, a newly\n allocated (unpinned) @MutableByteArray\\#@ (with the original content\n copied over).\n\n To avoid undefined behaviour, the original @MutableByteArray\\#@ shall\n not be accessed anymore after a @resizeMutableByteArray\\#@ has been\n performed. Moreover, no reference to the old one should be kept in order\n to allow garbage collection of the original @MutableByteArray\\#@ in\n case a new @MutableByteArray\\#@ had to be allocated.") + , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by 'getSizeofMutableByteArray#'.") + , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n The returned 'MutableByteArray#' is either the original\n 'MutableByteArray#' resized in-place or, if not possible, a newly\n allocated (unpinned) 'MutableByteArray#' (with the original content\n copied over).\n\n To avoid undefined behaviour, the original 'MutableByteArray#' shall\n not be accessed anymore after a 'resizeMutableByteArray#' has been\n performed. Moreover, no reference to the old one should be kept in order\n to allow garbage collection of the original 'MutableByteArray#' in\n case a new 'MutableByteArray#' had to be allocated.") , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.") , ("sizeofByteArray#","Return the size of the array in bytes.") , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of shrink and resize operations on the same mutable byte\n array.") @@ -119,7 +119,7 @@ , ("indexAddrArray#","Read a machine address; offset in machine words.") , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.") , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.") - , ("indexStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.") + , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.") , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.") , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.") , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") @@ -135,7 +135,7 @@ , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.") , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.") , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.") - , ("indexWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.") + , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.") , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.") , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") @@ -149,7 +149,7 @@ , ("readAddrArray#","Read a machine address; offset in machine words.") , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.") , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.") - , ("readStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.") + , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.") , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.") , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.") , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.") @@ -165,7 +165,7 @@ , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.") , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.") , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.") - , ("readWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.") + , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.") , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.") , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.") , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.") @@ -179,7 +179,7 @@ , ("writeAddrArray#","Write a machine address; offset in machine words.") , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.") , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.") - , ("writeStablePtrArray#","Write a @StablePtr#@ value; offset in machine words.") + , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.") , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.") , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.") , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.") @@ -195,20 +195,20 @@ , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.") , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.") , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.") - , ("writeWord8ArrayAsStablePtr#","Write a @StablePtr#@ value; offset in bytes.") + , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.") , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.") , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.") , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.") , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.") - , ("compareByteArrays#","@compareByteArrays# src1 src1_ofs src2 src2_ofs n@ compares\n @n@ bytes starting at offset @src1_ofs@ in the first\n @ByteArray#@ @src1@ to the range of @n@ bytes\n (i.e. same length) starting at offset @src2_ofs@ of the second\n @ByteArray#@ @src2@. Both arrays must fully contain the\n specified ranges, but this is not checked. Returns an @Int#@\n less than, equal to, or greater than zero if the range is found,\n respectively, to be byte-wise lexicographically less than, to\n match, or be greater than the second range.") - , ("copyByteArray#","@copyByteArray# src src_ofs dst dst_ofs n@ copies the range\n starting at offset @src_ofs@ of length @n@ from the\n @ByteArray#@ @src@ to the @MutableByteArray#@ @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.") + , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n @n@ bytes starting at offset @src1_ofs@ in the first\n 'ByteArray#' @src1@ to the range of @n@ bytes\n (i.e. same length) starting at offset @src2_ofs@ of the second\n 'ByteArray#' @src2@. Both arrays must fully contain the\n specified ranges, but this is not checked. Returns an 'Int#'\n less than, equal to, or greater than zero if the range is found,\n respectively, to be byte-wise lexicographically less than, to\n match, or be greater than the second range.") + , ("copyByteArray#","@'copyByteArray#' src src_ofs dst dst_ofs n@ copies the range\n starting at offset @src_ofs@ of length @n@ from the\n 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.") , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n allowed to overlap, although this is only possible when the same array is provided\n as both the source and the destination.") , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n The ByteArray\\# and the memory region at Addr\\# must fully contain the\n specified ranges, but this is not checked. The Addr\\# must not point into the\n ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n either.") , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n pinned), but this is not checked either.") , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n but this is not checked either.") - , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len)@ of\n the @MutableByteArray#@ to the byte @c@.") + , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n the 'MutableByteArray#' to the byte @c@.") , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n the new value, perform an atomic compare and swap i.e. write the new\n value if the current value matches the provided old value. Returns\n the value of the element before the operation. Implies a full memory\n barrier.") @@ -224,8 +224,8 @@ , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n atomically XOR the value into the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") , ("Addr#"," An arbitrary machine address assumed to point outside\n the garbage-collected heap. ") , ("nullAddr#"," The null address. ") - , ("minusAddr#","Result is meaningless if two @Addr\\#@s are so far apart that their\n difference doesn't fit in an @Int\\#@.") - , ("remAddr#","Return the remainder when the @Addr\\#@ arg, treated like an @Int\\#@,\n is divided by the @Int\\#@ arg.") + , ("minusAddr#","Result is meaningless if two 'Addr#'s are so far apart that their\n difference doesn't fit in an 'Int#'.") + , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n is divided by the 'Int#' arg.") , ("addr2Int#","Coerce directly from address to int.") , ("int2Addr#","Coerce directly from int to address.") , ("indexCharOffAddr#","Reads 8-bit character; offset in bytes.") @@ -248,76 +248,89 @@ , ("fetchXorWordAddr#","Given an address, and a value to XOR,\n atomically XOR the value into the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") , ("atomicReadWordAddr#","Given an address, read a machine word. Implies a full memory barrier.") , ("atomicWriteWordAddr#","Given an address, write a machine word. Implies a full memory barrier.") - , ("MutVar#","A @MutVar\\#@ behaves like a single-element mutable array.") - , ("newMutVar#","Create @MutVar\\#@ with specified initial value in specified state thread.") - , ("readMutVar#","Read contents of @MutVar\\#@. Result is not yet evaluated.") - , ("writeMutVar#","Write contents of @MutVar\\#@.") - , ("atomicModifyMutVar2#"," Modify the contents of a @MutVar\\#@, returning the previous\n contents and the result of applying the given function to the\n previous contents. Note that this isn't strictly\n speaking the correct type for this function; it should really be\n @MutVar\\# s a -> (a -> (a,b)) -> State\\# s -> (\\# State\\# s, a, (a, b) \\#)@,\n but we don't know about pairs here. ") - , ("atomicModifyMutVar_#"," Modify the contents of a @MutVar\\#@, returning the previous\n contents and the result of applying the given function to the\n previous contents. ") - , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n the first value passed to this function and the value\n stored inside the @MutVar\\#@. If the pointers are equal,\n replace the stored value with the second value passed to this\n function, otherwise do nothing.\n Returns the final value stored inside the @MutVar\\#@.\n The @Int\\#@ indicates whether a swap took place,\n with @1\\#@ meaning that we didn't swap, and @0\\#@\n that we did.\n Implies a full memory barrier.\n Because the comparison is done on the level of pointers,\n all of the difficulties of using\n @reallyUnsafePtrEquality\\#@ correctly apply to\n @casMutVar\\#@ as well.\n ") - , ("newTVar#","Create a new @TVar\\#@ holding a specified initial value.") - , ("readTVar#","Read contents of @TVar\\#@ inside an STM transaction,\n i.e. within a call to @atomically\\#@.\n Does not force evaluation of the result.") - , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction.\n Does not force evaluation of the result.") - , ("writeTVar#","Write contents of @TVar\\#@.") - , ("MVar#"," A shared mutable variable (/not/ the same as a @MutVar\\#@!).\n (Note: in a non-concurrent implementation, @(MVar\\# a)@ can be\n represented by @(MutVar\\# (Maybe a))@.) ") - , ("newMVar#","Create new @MVar\\#@; initially empty.") - , ("takeMVar#","If @MVar\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.") - , ("tryTakeMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of @MVar\\#@, and set @MVar\\#@ empty.") - , ("putMVar#","If @MVar\\#@ is full, block until it becomes empty.\n Then store value arg as its new contents.") - , ("tryPutMVar#","If @MVar\\#@ is full, immediately return with integer 0.\n Otherwise, store value arg as @MVar\\#@'s new contents, and return with integer 1.") - , ("readMVar#","If @MVar\\#@ is empty, block until it becomes full.\n Then read its contents without modifying the MVar, without possibility\n of intervention from other threads.") - , ("tryReadMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of @MVar\\#@.") - , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.") - , ("IOPort#"," A shared I/O port is almost the same as a @MVar\\#@!).\n The main difference is that IOPort has no deadlock detection or\n deadlock breaking code that forcibly releases the lock. ") - , ("newIOPort#","Create new @IOPort\\#@; initially empty.") - , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.\n Throws an @IOPortException@ if another thread is already\n waiting to read this @IOPort\\#@.") - , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0,\n throwing an @IOPortException@.\n Otherwise, store value arg as @IOPort\\#@'s new contents,\n and return with integer 1. ") + , ("MutVar#","A 'MutVar#' behaves like a single-element mutable array.") + , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.") + , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.") + , ("writeMutVar#","Write contents of 'MutVar#'.") + , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. Note that this isn't strictly\n speaking the correct type for this function; it should really be\n @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@,\n but we don't know about pairs here. ") + , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. ") + , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n the first value passed to this function and the value\n stored inside the 'MutVar#'. If the pointers are equal,\n replace the stored value with the second value passed to this\n function, otherwise do nothing.\n Returns the final value stored inside the 'MutVar#'.\n The 'Int#' indicates whether a swap took place,\n with @1#@ meaning that we didn't swap, and @0#@\n that we did.\n Implies a full memory barrier.\n Because the comparison is done on the level of pointers,\n all of the difficulties of using\n 'reallyUnsafePtrEquality#' correctly apply to\n 'casMutVar#' as well.\n ") + , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n thrown.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") + , ("maskAsyncExceptions#"," @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous\n exceptions are deferred until after evaluation has finished.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") + , ("maskUninterruptible#"," @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n exceptions are deferred until after evaluation has finished.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") + , ("unmaskAsyncExceptions#"," @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n exceptions are unmasked.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") + , ("PromptTag#"," See \"GHC.Prim#continuations\". ") + , ("newPromptTag#"," See \"GHC.Prim#continuations\". ") + , ("prompt#"," See \"GHC.Prim#continuations\". ") + , ("control0#"," See \"GHC.Prim#continuations\". ") + , ("newTVar#","Create a new 'TVar#' holding a specified initial value.") + , ("readTVar#","Read contents of 'TVar#' inside an STM transaction,\n i.e. within a call to 'atomically#'.\n Does not force evaluation of the result.") + , ("readTVarIO#","Read contents of 'TVar#' outside an STM transaction.\n Does not force evaluation of the result.") + , ("writeTVar#","Write contents of 'TVar#'.") + , ("MVar#"," A shared mutable variable (/not/ the same as a 'MutVar#'!).\n (Note: in a non-concurrent implementation, @('MVar#' a)@ can be\n represented by @('MutVar#' (Maybe a))@.) ") + , ("newMVar#","Create new 'MVar#'; initially empty.") + , ("takeMVar#","If 'MVar#' is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.") + , ("tryTakeMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.") + , ("putMVar#","If 'MVar#' is full, block until it becomes empty.\n Then store value arg as its new contents.") + , ("tryPutMVar#","If 'MVar#' is full, immediately return with integer 0.\n Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.") + , ("readMVar#","If 'MVar#' is empty, block until it becomes full.\n Then read its contents without modifying the MVar, without possibility\n of intervention from other threads.") + , ("tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n Otherwise, return with integer 1 and contents of 'MVar#'.") + , ("isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.") + , ("IOPort#"," A shared I/O port is almost the same as an 'MVar#'.\n The main difference is that IOPort has no deadlock detection or\n deadlock breaking code that forcibly releases the lock. ") + , ("newIOPort#","Create new 'IOPort#'; initially empty.") + , ("readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.\n Throws an 'IOPortException' if another thread is already\n waiting to read this 'IOPort#'.") + , ("writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n throwing an 'IOPortException'.\n Otherwise, store value arg as 'IOPort#''s new contents,\n and return with integer 1. ") , ("delay#","Sleep specified number of microseconds.") , ("waitRead#","Block until input is available on specified file descriptor.") , ("waitWrite#","Block until output is possible on specified file descriptor.") - , ("State#"," @State\\#@ is the primitive, unlifted type of states. It has\n one type parameter, thus @State\\# RealWorld@, or @State\\# s@,\n where s is a type variable. The only purpose of the type parameter\n is to keep different state threads separate. It is represented by\n nothing at all. ") - , ("RealWorld"," @RealWorld@ is deeply magical. It is /primitive/, but it is not\n /unlifted/ (hence @ptrArg@). We never manipulate values of type\n @RealWorld@; it's only used in the type system, to parameterise @State\\#@. ") - , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n type, whose (unique) value is returned by @myThreadId\\#@. The\n other operations can be omitted.)") - , ("mkWeak#"," @mkWeak# k v finalizer s@ creates a weak reference to value @k@,\n with an associated reference to some value @v@. If @k@ is still\n alive then @v@ can be retrieved using @deRefWeak#@. Note that\n the type of @k@ must be represented by a pointer (i.e. of kind @TYPE 'LiftedRep@ or @TYPE 'UnliftedRep@). ") - , ("addCFinalizerToWeak#"," @addCFinalizerToWeak# fptr ptr flag eptr w@ attaches a C\n function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n @flag@ is zero, @fptr@ will be called with one argument,\n @ptr@. Otherwise, it will be called with two arguments,\n @eptr@ and @ptr@. @addCFinalizerToWeak#@ returns\n 1 on success, or 0 if @w@ is already dead. ") - , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n containing the new state of the world and an \"unboxed Maybe\",\n represented by an @Int#@ and a (possibly invalid) finalization\n action. An @Int#@ of @1@ indicates that the finalizer is valid. The\n return value @b@ from the finalizer should be ignored. ") + , ("State#"," 'State#' is the primitive, unlifted type of states. It has\n one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,\n where s is a type variable. The only purpose of the type parameter\n is to keep different state threads separate. It is represented by\n nothing at all. ") + , ("RealWorld"," 'RealWorld' is deeply magical. It is /primitive/, but it is not\n /unlifted/ (hence @ptrArg@). We never manipulate values of type\n 'RealWorld'; it's only used in the type system, to parameterise 'State#'. ") + , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n type, whose (unique) value is returned by 'myThreadId#'. The\n other operations can be omitted.)") + , ("labelThread#","Set the label of the given thread. The @ByteArray#@ should contain\n a UTF-8-encoded string.") + , ("threadLabel#","Get the label of the given thread.\n Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag\n denoting @Just@.\n\n @since 0.10") + , ("threadStatus#","Get the status of the given thread. Result is\n @(ThreadStatus, Capability, Locked)@ where\n @ThreadStatus@ is one of the status constants defined in\n @rts/Constants.h@, @Capability@ is the number of\n the capability which currently owns the thread, and\n @Locked@ is a boolean indicating whether the\n thread is bound to that capability.\n\n @since 0.9") + , ("listThreads#"," Returns an array of the threads started by the program. Note that this\n threads which have finished execution may or may not be present in this\n list, depending upon whether they have been collected by the garbage collector.\n\n @since 0.10") + , ("mkWeak#"," @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,\n with an associated reference to some value @v@. If @k@ is still\n alive then @v@ can be retrieved using 'deRefWeak#'. Note that\n the type of @k@ must be represented by a pointer (i.e. of kind\n @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). ") + , ("addCFinalizerToWeak#"," @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C\n function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n @flag@ is zero, @fptr@ will be called with one argument,\n @ptr@. Otherwise, it will be called with two arguments,\n @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns\n 1 on success, or 0 if @w@ is already dead. ") + , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n containing the new state of the world and an \"unboxed Maybe\",\n represented by an 'Int#' and a (possibly invalid) finalization\n action. An 'Int#' of @1@ indicates that the finalizer is valid. The\n return value @b@ from the finalizer should be ignored. ") , ("compactNew#"," Create a new CNF with a single compact block. The argument is\n the capacity of the compact block (in bytes, not words).\n The capacity is rounded up to a multiple of the allocator block size\n and is capped to one mega block. ") , ("compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n determines the capacity of each compact block in the CNF. It\n does not retroactively affect existing compact blocks in the CNF. ") , ("compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ") , ("compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ") , ("compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n first compact block of a CNF.") - , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n next compact block and its utilized size, or @nullAddr\\#@ if the\n argument was the last compact block in the CNF. ") - , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n bytes) given by the first argument. The @Addr\\#@ is a pointer\n to previous compact block of the CNF or @nullAddr\\#@ to create a\n new CNF with a single compact block.\n\n The resulting block is not known to the GC until\n @compactFixupPointers\\#@ is called on it, and care must be taken\n so that the address does not escape or memory will be leaked.\n ") + , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n next compact block and its utilized size, or 'nullAddr#' if the\n argument was the last compact block in the CNF. ") + , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n bytes) given by the first argument. The 'Addr#' is a pointer\n to previous compact block of the CNF or 'nullAddr#' to create a\n new CNF with a single compact block.\n\n The resulting block is not known to the GC until\n 'compactFixupPointers#' is called on it, and care must be taken\n so that the address does not escape or memory will be leaked.\n ") , ("compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n address of the root object in the old address space, fix up\n the internal pointers inside the CNF to account for\n a different position in memory than when it was serialized.\n This method must be called exactly once after importing\n a serialized CNF. It returns the new CNF and the new adjusted\n root address. ") - , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n @Compact\\#@ (a CNF), evaluating any unevaluated components\n at the same time. Note: @compactAdd\\#@ is not thread-safe, so\n only one thread may call @compactAdd\\#@ with a particular\n @Compact\\#@ at any given time. The primop does not\n enforce any mutual exclusion; the caller is expected to\n arrange this. ") - , ("compactAddWithSharing#"," Like @compactAdd\\#@, but retains sharing and cycles\n during compaction. ") + , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n 'Compact#' (a CNF), evaluating any unevaluated components\n at the same time. Note: 'compactAdd#' is not thread-safe, so\n only one thread may call 'compactAdd#' with a particular\n 'Compact#' at any given time. The primop does not\n enforce any mutual exclusion; the caller is expected to\n arrange this. ") + , ("compactAddWithSharing#"," Like 'compactAdd#', but retains sharing and cycles\n during compaction. ") , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n in the CNF. ") - , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ") + , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ") , ("numSparks#"," Returns the number of sparks in the local spark pool. ") - , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n of the computation \\tt{k}.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; ticket \\#21868 for details. ") + , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n of the computation @k@.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") + , ("dataToTag#"," Evaluates the argument and returns the tag of the result.\n Tags are Zero-indexed; the first constructor has tag zero. ") , ("BCO"," Primitive bytecode type. ") - , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ") - , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n essentially an @unsafeCoerce\\#@, but if implemented as such\n the core lint pass complains and fails to compile.\n As a primop, it is opaque to core/stg, and only appears\n in cmm (where the copy propagation pass will get rid of it).\n Note that \"a\" must be a value, not a thunk! It's too late\n for strictness analysis to enforce this, so you're on your\n own to guarantee this. Also note that @Addr\\#@ is not a GC\n pointer - up to you to guarantee that it does not become\n a dangling pointer immediately after you get it.") + , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ") + , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n essentially an 'unsafeCoerce#', but if implemented as such\n the core lint pass complains and fails to compile.\n As a primop, it is opaque to core/stg, and only appears\n in cmm (where the copy propagation pass will get rid of it).\n Note that \"a\" must be a value, not a thunk! It's too late\n for strictness analysis to enforce this, so you're on your\n own to guarantee this. Also note that 'Addr#' is not a GC\n pointer - up to you to guarantee that it does not become\n a dangling pointer immediately after you get it.") , ("mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n the BCO when evaluated. ") - , ("newBCO#"," @newBCO\\# instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n resulting object encodes a function of the given arity with the instructions\n encoded in @instrs@, and a static reference table usage bitmap given by\n @bitmap@. ") - , ("unpackClosure#"," @unpackClosure\\# closure@ copies the closure and pointers in the\n payload of the given closure into two new arrays, and returns a pointer to\n the first word of the closure's info table, a non-pointer array for the raw\n bytes of the closure, and a pointer array for the pointers in the payload. ") - , ("closureSize#"," @closureSize\\# closure@ returns the size of the given closure in\n machine words. ") - , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n not profiling). Takes a dummy argument which can be used to\n avoid the call to @getCurrentCCS\\#@ being floated out by the\n simplifier, which would result in an uninformative stack\n (\"CAF\"). ") + , ("newBCO#"," @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n resulting object encodes a function of the given arity with the instructions\n encoded in @instrs@, and a static reference table usage bitmap given by\n @bitmap@. ") + , ("unpackClosure#"," @'unpackClosure#' closure@ copies the closure and pointers in the\n payload of the given closure into two new arrays, and returns a pointer to\n the first word of the closure's info table, a non-pointer array for the raw\n bytes of the closure, and a pointer array for the pointers in the payload. ") + , ("closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n machine words. ") + , ("getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n not profiling). Takes a dummy argument which can be used to\n avoid the call to 'getCurrentCCS#' being floated out by the\n simplifier, which would result in an uninformative stack\n (\"CAF\"). ") , ("clearCCS#"," Run the supplied IO action with an empty CCS. For example, this\n is used by the interpreter to run an interpreted computation\n without the call stack showing that it was invoked from GHC. ") , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n (value is @NULL@ if the table does not exist or there is no information\n about the closure).") - , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits representation polymorphism in both\n @a@ and @b@, so that types like @Int\\# -> Int\\#@ can still be\n well-kinded.\n ") - , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n It does not pass any information at runtime.\n See also @GHC.Magic.runRW\\#@. ") - , ("void#"," This is an alias for the unboxed unit tuple constructor.\n In earlier versions of GHC, @void\\#@ was a value\n of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n ") - , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A @Proxy#@\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") - , ("proxy#"," Witness for an unboxed @Proxy#@ value, which has no runtime\n representation. ") - , ("seq"," The value of @seq a b@ is bottom if @a@ is bottom, and\n otherwise equal to @b@. In other words, it evaluates the first\n argument @a@ to weak head normal form (WHNF). @seq@ is usually\n introduced to improve performance by avoiding unneeded laziness.\n\n A note on evaluation order: the expression @seq a b@ does\n /not/ guarantee that @a@ will be evaluated before @b@.\n The only guarantee given by @seq@ is that the both @a@\n and @b@ will be evaluated before @seq@ returns a value.\n In particular, this means that @b@ may be evaluated before\n @a@. If you need to guarantee a specific order of evaluation,\n you must use the function @pseq@ from the \"parallel\" package. ") - , ("unsafeCoerce#"," The function @unsafeCoerce\\#@ allows you to side-step the typechecker entirely. That\n is, it allows you to coerce any type into any other type. If you use this function,\n you had better get it right, otherwise segmentation faults await. It is generally\n used when you want to write a program that you know is well-typed, but where Haskell's\n type system is not expressive enough to prove that it is well typed.\n\n The following uses of @unsafeCoerce\\#@ are supposed to work (i.e. not lead to\n spurious compile-time or run-time crashes):\n\n * Casting any lifted type to @Any@\n\n * Casting @Any@ back to the real type\n\n * Casting an unboxed type to another unboxed type of the same size.\n (Casting between floating-point and integral types does not work.\n See the @GHC.Float@ module for functions to do work.)\n\n * Casting between two types that have the same runtime representation. One case is when\n the two types differ only in \"phantom\" type parameters, for example\n @Ptr Int@ to @Ptr Float@, or @[Int]@ to @[Float]@ when the list is\n known to be empty. Also, a @newtype@ of a type @T@ has the same representation\n at runtime as @T@.\n\n Other uses of @unsafeCoerce\\#@ are undefined. In particular, you should not use\n @unsafeCoerce\\#@ to cast a T to an algebraic data type D, unless T is also\n an algebraic data type. For example, do not cast @Int->Int@ to @Bool@, even if\n you later cast that @Bool@ back to @Int->Int@ before applying it. The reasons\n have to do with GHC's internal representation details (for the cognoscenti, data values\n can be entered but function closures cannot). If you want a safe type to cast things\n to, use @Any@, which is not an algebraic data type.\n\n ") + , ("FUN","The builtin function type, written in infix form as @a % m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @'FUN' m a b@ permits representation polymorphism in both\n @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n well-kinded.\n ") + , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n It does not pass any information at runtime.\n See also 'GHC.Magic.runRW#'. ") + , ("void#"," This is an alias for the unboxed unit tuple constructor.\n In earlier versions of GHC, 'void#' was a value\n of the primitive type 'Void#', which is now defined to be @(# #)@.\n ") + , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A 'Proxy#'\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") + , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n representation. ") + , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n otherwise equal to @b@. In other words, it evaluates the first\n argument @a@ to weak head normal form (WHNF). 'seq' is usually\n introduced to improve performance by avoiding unneeded laziness.\n\n A note on evaluation order: the expression @'seq' a b@ does\n /not/ guarantee that @a@ will be evaluated before @b@.\n The only guarantee given by 'seq' is that the both @a@\n and @b@ will be evaluated before 'seq' returns a value.\n In particular, this means that @b@ may be evaluated before\n @a@. If you need to guarantee a specific order of evaluation,\n you must use the function 'pseq' from the \"parallel\" package. ") + , ("unsafeCoerce#"," The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That\n is, it allows you to coerce any type into any other type. If you use this function,\n you had better get it right, otherwise segmentation faults await. It is generally\n used when you want to write a program that you know is well-typed, but where Haskell's\n type system is not expressive enough to prove that it is well typed.\n\n The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to\n spurious compile-time or run-time crashes):\n\n * Casting any lifted type to 'Any'\n\n * Casting 'Any' back to the real type\n\n * Casting an unboxed type to another unboxed type of the same size.\n (Casting between floating-point and integral types does not work.\n See the \"GHC.Float\" module for functions to do work.)\n\n * Casting between two types that have the same runtime representation. One case is when\n the two types differ only in \"phantom\" type parameters, for example\n @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is\n known to be empty. Also, a @newtype@ of a type @T@ has the same representation\n at runtime as @T@.\n\n Other uses of 'unsafeCoerce#' are undefined. In particular, you should not use\n 'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also\n an algebraic data type. For example, do not cast @'Int'->'Int'@ to 'Bool', even if\n you later cast that 'Bool' back to @'Int'->'Int'@ before applying it. The reasons\n have to do with GHC's internal representation details (for the cognoscenti, data values\n can be entered but function closures cannot). If you want a safe type to cast things\n to, use 'Any', which is not an algebraic data type.\n\n ") , ("traceEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the binary object passed as the first argument with\n the given length passed as the second argument. The event will be\n emitted to the @.eventlog@ file. ") , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ") - , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n with a function in @GHC.Stack.CloneStack@. Please check the\n documentation in this module for more detailed explanations. ") - , ("coerce"," The function @coerce@ allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n @RuntimeRep@ type argument is marked as @Inferred@, meaning\n that it is not available for visible type application. This means\n the typechecker will accept @coerce @Int @Age 42@.\n ") + , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n with a function in \"GHC.Stack.CloneStack\". Please check the\n documentation in that module for more detailed explanations. ") + , ("coerce"," The function 'coerce' allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n 'RuntimeRep' type argument is marked as 'Inferred', meaning\n that it is not available for visible type application. This means\n the typechecker will accept @'coerce' @'Int' @Age 42@.\n ") , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ") @@ -558,30 +571,30 @@ , ("quotWord16X32#"," Rounds towards zero element-wise. ") , ("quotWord32X16#"," Rounds towards zero element-wise. ") , ("quotWord64X8#"," Rounds towards zero element-wise. ") - , ("remInt8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remInt64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") - , ("remWord64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ") + , ("remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") + , ("remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ") , ("negateInt8X16#"," Negate element-wise. ") , ("negateInt16X8#"," Negate element-wise. ") , ("negateInt32X4#"," Negate element-wise. ") diff --git a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl @@ -168,6 +168,9 @@ primOpHasSideEffects MaskUninterruptibleOp = True primOpHasSideEffects UnmaskAsyncExceptionsOp = True primOpHasSideEffects MaskStatus = True +primOpHasSideEffects NewPromptTagOp = True +primOpHasSideEffects PromptOp = True +primOpHasSideEffects Control0Op = True primOpHasSideEffects AtomicallyOp = True primOpHasSideEffects RetryOp = True primOpHasSideEffects CatchRetryOp = True @@ -199,6 +202,7 @@ primOpHasSideEffects IsCurrentThreadBoundOp = True primOpHasSideEffects NoDuplicateOp = True primOpHasSideEffects ThreadStatusOp = True +primOpHasSideEffects ListThreadsOp = True primOpHasSideEffects MkWeakOp = True primOpHasSideEffects MkWeakNoFinalizerOp = True primOpHasSideEffects AddCFinalizerToWeakOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -562,11 +562,17 @@ , CasMutVarOp , CatchOp , RaiseOp + , RaiseUnderflowOp + , RaiseOverflowOp + , RaiseDivZeroOp , RaiseIOOp , MaskAsyncExceptionsOp , MaskUninterruptibleOp , UnmaskAsyncExceptionsOp , MaskStatus + , NewPromptTagOp + , PromptOp + , Control0Op , AtomicallyOp , RetryOp , CatchRetryOp @@ -597,7 +603,9 @@ , LabelThreadOp , IsCurrentThreadBoundOp , NoDuplicateOp + , GetThreadLabelOp , ThreadStatusOp + , ListThreadsOp , MkWeakOp , MkWeakNoFinalizerOp , AddCFinalizerToWeakOp diff --git a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl @@ -33,11 +33,17 @@ primOpOutOfLine CasMutVarOp = True primOpOutOfLine CatchOp = True primOpOutOfLine RaiseOp = True +primOpOutOfLine RaiseUnderflowOp = True +primOpOutOfLine RaiseOverflowOp = True +primOpOutOfLine RaiseDivZeroOp = True primOpOutOfLine RaiseIOOp = True primOpOutOfLine MaskAsyncExceptionsOp = True primOpOutOfLine MaskUninterruptibleOp = True primOpOutOfLine UnmaskAsyncExceptionsOp = True primOpOutOfLine MaskStatus = True +primOpOutOfLine NewPromptTagOp = True +primOpOutOfLine PromptOp = True +primOpOutOfLine Control0Op = True primOpOutOfLine AtomicallyOp = True primOpOutOfLine RetryOp = True primOpOutOfLine CatchRetryOp = True @@ -67,7 +73,9 @@ primOpOutOfLine LabelThreadOp = True primOpOutOfLine IsCurrentThreadBoundOp = True primOpOutOfLine NoDuplicateOp = True +primOpOutOfLine GetThreadLabelOp = True primOpOutOfLine ThreadStatusOp = True +primOpOutOfLine ListThreadsOp = True primOpOutOfLine MkWeakOp = True primOpOutOfLine MkWeakNoFinalizerOp = True primOpOutOfLine AddCFinalizerToWeakOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -562,11 +562,17 @@ primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [runtimeRep1TyVarInf, levity2TyVarInf, openAlphaTyVarSpec, levPolyBetaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), (mkVisFunTyMany (levPolyBetaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy] (openBetaTy) +primOpInfo RaiseUnderflowOp = mkGenPrimOp (fsLit "raiseUnderflow#") [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy) +primOpInfo RaiseOverflowOp = mkGenPrimOp (fsLit "raiseOverflow#") [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy) +primOpInfo RaiseDivZeroOp = mkGenPrimOp (fsLit "raiseDivZero#") [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy) primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy])) primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo NewPromptTagOp = mkGenPrimOp (fsLit "newPromptTag#") [alphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkPromptTagPrimTy alphaTy])) +primOpInfo PromptOp = mkGenPrimOp (fsLit "prompt#") [alphaTyVarSpec] [mkPromptTagPrimTy alphaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo Control0Op = mkGenPrimOp (fsLit "control0#") [runtimeRep2TyVarInf, alphaTyVarSpec, openBetaTyVarSpec] [mkPromptTagPrimTy alphaTy, (mkVisFunTyMany ((mkVisFunTyMany ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy])))) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])))))) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy])) primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) @@ -594,10 +600,12 @@ primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVarSpec] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, byteArrayPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVarSpec] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo GetThreadLabelOp = mkGenPrimOp (fsLit "threadLabel#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, byteArrayPrimTy])) primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo ListThreadsOp = mkGenPrimOp (fsLit "listThreads#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkArrayPrimTy threadIdPrimTy])) primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy])) primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy])) primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) @@ -629,7 +637,7 @@ primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVarSpec] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVarSpec] [intPrimTy] (alphaTy) -primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) +primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVarSpec] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVarSpec, deltaTyVarSpec] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -2,10 +2,15 @@ , lazyApply2Dmd , topDmd] topDiv primOpStrictness RaiseOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv +primOpStrictness RaiseUnderflowOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv +primOpStrictness RaiseOverflowOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv +primOpStrictness RaiseDivZeroOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv primOpStrictness RaiseIOOp = \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv +primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv +primOpStrictness Control0Op = \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv primOpStrictness AtomicallyOp = \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv primOpStrictness RetryOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv primOpStrictness CatchRetryOp = \ _arity -> mkClosedDmdSig [ lazyApply1Dmd diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -1,1307 +1,1315 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1303 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 0 -primOpTag CharGeOp = 1 -primOpTag CharEqOp = 2 -primOpTag CharNeOp = 3 -primOpTag CharLtOp = 4 -primOpTag CharLeOp = 5 -primOpTag OrdOp = 6 -primOpTag Int8ToIntOp = 7 -primOpTag IntToInt8Op = 8 -primOpTag Int8NegOp = 9 -primOpTag Int8AddOp = 10 -primOpTag Int8SubOp = 11 -primOpTag Int8MulOp = 12 -primOpTag Int8QuotOp = 13 -primOpTag Int8RemOp = 14 -primOpTag Int8QuotRemOp = 15 -primOpTag Int8SllOp = 16 -primOpTag Int8SraOp = 17 -primOpTag Int8SrlOp = 18 -primOpTag Int8ToWord8Op = 19 -primOpTag Int8EqOp = 20 -primOpTag Int8GeOp = 21 -primOpTag Int8GtOp = 22 -primOpTag Int8LeOp = 23 -primOpTag Int8LtOp = 24 -primOpTag Int8NeOp = 25 -primOpTag Word8ToWordOp = 26 -primOpTag WordToWord8Op = 27 -primOpTag Word8AddOp = 28 -primOpTag Word8SubOp = 29 -primOpTag Word8MulOp = 30 -primOpTag Word8QuotOp = 31 -primOpTag Word8RemOp = 32 -primOpTag Word8QuotRemOp = 33 -primOpTag Word8AndOp = 34 -primOpTag Word8OrOp = 35 -primOpTag Word8XorOp = 36 -primOpTag Word8NotOp = 37 -primOpTag Word8SllOp = 38 -primOpTag Word8SrlOp = 39 -primOpTag Word8ToInt8Op = 40 -primOpTag Word8EqOp = 41 -primOpTag Word8GeOp = 42 -primOpTag Word8GtOp = 43 -primOpTag Word8LeOp = 44 -primOpTag Word8LtOp = 45 -primOpTag Word8NeOp = 46 -primOpTag Int16ToIntOp = 47 -primOpTag IntToInt16Op = 48 -primOpTag Int16NegOp = 49 -primOpTag Int16AddOp = 50 -primOpTag Int16SubOp = 51 -primOpTag Int16MulOp = 52 -primOpTag Int16QuotOp = 53 -primOpTag Int16RemOp = 54 -primOpTag Int16QuotRemOp = 55 -primOpTag Int16SllOp = 56 -primOpTag Int16SraOp = 57 -primOpTag Int16SrlOp = 58 -primOpTag Int16ToWord16Op = 59 -primOpTag Int16EqOp = 60 -primOpTag Int16GeOp = 61 -primOpTag Int16GtOp = 62 -primOpTag Int16LeOp = 63 -primOpTag Int16LtOp = 64 -primOpTag Int16NeOp = 65 -primOpTag Word16ToWordOp = 66 -primOpTag WordToWord16Op = 67 -primOpTag Word16AddOp = 68 -primOpTag Word16SubOp = 69 -primOpTag Word16MulOp = 70 -primOpTag Word16QuotOp = 71 -primOpTag Word16RemOp = 72 -primOpTag Word16QuotRemOp = 73 -primOpTag Word16AndOp = 74 -primOpTag Word16OrOp = 75 -primOpTag Word16XorOp = 76 -primOpTag Word16NotOp = 77 -primOpTag Word16SllOp = 78 -primOpTag Word16SrlOp = 79 -primOpTag Word16ToInt16Op = 80 -primOpTag Word16EqOp = 81 -primOpTag Word16GeOp = 82 -primOpTag Word16GtOp = 83 -primOpTag Word16LeOp = 84 -primOpTag Word16LtOp = 85 -primOpTag Word16NeOp = 86 -primOpTag Int32ToIntOp = 87 -primOpTag IntToInt32Op = 88 -primOpTag Int32NegOp = 89 -primOpTag Int32AddOp = 90 -primOpTag Int32SubOp = 91 -primOpTag Int32MulOp = 92 -primOpTag Int32QuotOp = 93 -primOpTag Int32RemOp = 94 -primOpTag Int32QuotRemOp = 95 -primOpTag Int32SllOp = 96 -primOpTag Int32SraOp = 97 -primOpTag Int32SrlOp = 98 -primOpTag Int32ToWord32Op = 99 -primOpTag Int32EqOp = 100 -primOpTag Int32GeOp = 101 -primOpTag Int32GtOp = 102 -primOpTag Int32LeOp = 103 -primOpTag Int32LtOp = 104 -primOpTag Int32NeOp = 105 -primOpTag Word32ToWordOp = 106 -primOpTag WordToWord32Op = 107 -primOpTag Word32AddOp = 108 -primOpTag Word32SubOp = 109 -primOpTag Word32MulOp = 110 -primOpTag Word32QuotOp = 111 -primOpTag Word32RemOp = 112 -primOpTag Word32QuotRemOp = 113 -primOpTag Word32AndOp = 114 -primOpTag Word32OrOp = 115 -primOpTag Word32XorOp = 116 -primOpTag Word32NotOp = 117 -primOpTag Word32SllOp = 118 -primOpTag Word32SrlOp = 119 -primOpTag Word32ToInt32Op = 120 -primOpTag Word32EqOp = 121 -primOpTag Word32GeOp = 122 -primOpTag Word32GtOp = 123 -primOpTag Word32LeOp = 124 -primOpTag Word32LtOp = 125 -primOpTag Word32NeOp = 126 -primOpTag Int64ToIntOp = 127 -primOpTag IntToInt64Op = 128 -primOpTag Int64NegOp = 129 -primOpTag Int64AddOp = 130 -primOpTag Int64SubOp = 131 -primOpTag Int64MulOp = 132 -primOpTag Int64QuotOp = 133 -primOpTag Int64RemOp = 134 -primOpTag Int64SllOp = 135 -primOpTag Int64SraOp = 136 -primOpTag Int64SrlOp = 137 -primOpTag Int64ToWord64Op = 138 -primOpTag Int64EqOp = 139 -primOpTag Int64GeOp = 140 -primOpTag Int64GtOp = 141 -primOpTag Int64LeOp = 142 -primOpTag Int64LtOp = 143 -primOpTag Int64NeOp = 144 -primOpTag Word64ToWordOp = 145 -primOpTag WordToWord64Op = 146 -primOpTag Word64AddOp = 147 -primOpTag Word64SubOp = 148 -primOpTag Word64MulOp = 149 -primOpTag Word64QuotOp = 150 -primOpTag Word64RemOp = 151 -primOpTag Word64AndOp = 152 -primOpTag Word64OrOp = 153 -primOpTag Word64XorOp = 154 -primOpTag Word64NotOp = 155 -primOpTag Word64SllOp = 156 -primOpTag Word64SrlOp = 157 -primOpTag Word64ToInt64Op = 158 -primOpTag Word64EqOp = 159 -primOpTag Word64GeOp = 160 -primOpTag Word64GtOp = 161 -primOpTag Word64LeOp = 162 -primOpTag Word64LtOp = 163 -primOpTag Word64NeOp = 164 -primOpTag IntAddOp = 165 -primOpTag IntSubOp = 166 -primOpTag IntMulOp = 167 -primOpTag IntMul2Op = 168 -primOpTag IntMulMayOfloOp = 169 -primOpTag IntQuotOp = 170 -primOpTag IntRemOp = 171 -primOpTag IntQuotRemOp = 172 -primOpTag IntAndOp = 173 -primOpTag IntOrOp = 174 -primOpTag IntXorOp = 175 -primOpTag IntNotOp = 176 -primOpTag IntNegOp = 177 -primOpTag IntAddCOp = 178 -primOpTag IntSubCOp = 179 -primOpTag IntGtOp = 180 -primOpTag IntGeOp = 181 -primOpTag IntEqOp = 182 -primOpTag IntNeOp = 183 -primOpTag IntLtOp = 184 -primOpTag IntLeOp = 185 -primOpTag ChrOp = 186 -primOpTag IntToWordOp = 187 -primOpTag IntToFloatOp = 188 -primOpTag IntToDoubleOp = 189 -primOpTag WordToFloatOp = 190 -primOpTag WordToDoubleOp = 191 -primOpTag IntSllOp = 192 -primOpTag IntSraOp = 193 -primOpTag IntSrlOp = 194 -primOpTag WordAddOp = 195 -primOpTag WordAddCOp = 196 -primOpTag WordSubCOp = 197 -primOpTag WordAdd2Op = 198 -primOpTag WordSubOp = 199 -primOpTag WordMulOp = 200 -primOpTag WordMul2Op = 201 -primOpTag WordQuotOp = 202 -primOpTag WordRemOp = 203 -primOpTag WordQuotRemOp = 204 -primOpTag WordQuotRem2Op = 205 -primOpTag WordAndOp = 206 -primOpTag WordOrOp = 207 -primOpTag WordXorOp = 208 -primOpTag WordNotOp = 209 -primOpTag WordSllOp = 210 -primOpTag WordSrlOp = 211 -primOpTag WordToIntOp = 212 -primOpTag WordGtOp = 213 -primOpTag WordGeOp = 214 -primOpTag WordEqOp = 215 -primOpTag WordNeOp = 216 -primOpTag WordLtOp = 217 -primOpTag WordLeOp = 218 -primOpTag PopCnt8Op = 219 -primOpTag PopCnt16Op = 220 -primOpTag PopCnt32Op = 221 -primOpTag PopCnt64Op = 222 -primOpTag PopCntOp = 223 -primOpTag Pdep8Op = 224 -primOpTag Pdep16Op = 225 -primOpTag Pdep32Op = 226 -primOpTag Pdep64Op = 227 -primOpTag PdepOp = 228 -primOpTag Pext8Op = 229 -primOpTag Pext16Op = 230 -primOpTag Pext32Op = 231 -primOpTag Pext64Op = 232 -primOpTag PextOp = 233 -primOpTag Clz8Op = 234 -primOpTag Clz16Op = 235 -primOpTag Clz32Op = 236 -primOpTag Clz64Op = 237 -primOpTag ClzOp = 238 -primOpTag Ctz8Op = 239 -primOpTag Ctz16Op = 240 -primOpTag Ctz32Op = 241 -primOpTag Ctz64Op = 242 -primOpTag CtzOp = 243 -primOpTag BSwap16Op = 244 -primOpTag BSwap32Op = 245 -primOpTag BSwap64Op = 246 -primOpTag BSwapOp = 247 -primOpTag BRev8Op = 248 -primOpTag BRev16Op = 249 -primOpTag BRev32Op = 250 -primOpTag BRev64Op = 251 -primOpTag BRevOp = 252 -primOpTag Narrow8IntOp = 253 -primOpTag Narrow16IntOp = 254 -primOpTag Narrow32IntOp = 255 -primOpTag Narrow8WordOp = 256 -primOpTag Narrow16WordOp = 257 -primOpTag Narrow32WordOp = 258 -primOpTag DoubleGtOp = 259 -primOpTag DoubleGeOp = 260 -primOpTag DoubleEqOp = 261 -primOpTag DoubleNeOp = 262 -primOpTag DoubleLtOp = 263 -primOpTag DoubleLeOp = 264 -primOpTag DoubleAddOp = 265 -primOpTag DoubleSubOp = 266 -primOpTag DoubleMulOp = 267 -primOpTag DoubleDivOp = 268 -primOpTag DoubleNegOp = 269 -primOpTag DoubleFabsOp = 270 -primOpTag DoubleToIntOp = 271 -primOpTag DoubleToFloatOp = 272 -primOpTag DoubleExpOp = 273 -primOpTag DoubleExpM1Op = 274 -primOpTag DoubleLogOp = 275 -primOpTag DoubleLog1POp = 276 -primOpTag DoubleSqrtOp = 277 -primOpTag DoubleSinOp = 278 -primOpTag DoubleCosOp = 279 -primOpTag DoubleTanOp = 280 -primOpTag DoubleAsinOp = 281 -primOpTag DoubleAcosOp = 282 -primOpTag DoubleAtanOp = 283 -primOpTag DoubleSinhOp = 284 -primOpTag DoubleCoshOp = 285 -primOpTag DoubleTanhOp = 286 -primOpTag DoubleAsinhOp = 287 -primOpTag DoubleAcoshOp = 288 -primOpTag DoubleAtanhOp = 289 -primOpTag DoublePowerOp = 290 -primOpTag DoubleDecode_2IntOp = 291 -primOpTag DoubleDecode_Int64Op = 292 -primOpTag FloatGtOp = 293 -primOpTag FloatGeOp = 294 -primOpTag FloatEqOp = 295 -primOpTag FloatNeOp = 296 -primOpTag FloatLtOp = 297 -primOpTag FloatLeOp = 298 -primOpTag FloatAddOp = 299 -primOpTag FloatSubOp = 300 -primOpTag FloatMulOp = 301 -primOpTag FloatDivOp = 302 -primOpTag FloatNegOp = 303 -primOpTag FloatFabsOp = 304 -primOpTag FloatToIntOp = 305 -primOpTag FloatExpOp = 306 -primOpTag FloatExpM1Op = 307 -primOpTag FloatLogOp = 308 -primOpTag FloatLog1POp = 309 -primOpTag FloatSqrtOp = 310 -primOpTag FloatSinOp = 311 -primOpTag FloatCosOp = 312 -primOpTag FloatTanOp = 313 -primOpTag FloatAsinOp = 314 -primOpTag FloatAcosOp = 315 -primOpTag FloatAtanOp = 316 -primOpTag FloatSinhOp = 317 -primOpTag FloatCoshOp = 318 -primOpTag FloatTanhOp = 319 -primOpTag FloatAsinhOp = 320 -primOpTag FloatAcoshOp = 321 -primOpTag FloatAtanhOp = 322 -primOpTag FloatPowerOp = 323 -primOpTag FloatToDoubleOp = 324 -primOpTag FloatDecode_IntOp = 325 -primOpTag NewArrayOp = 326 -primOpTag ReadArrayOp = 327 -primOpTag WriteArrayOp = 328 -primOpTag SizeofArrayOp = 329 -primOpTag SizeofMutableArrayOp = 330 -primOpTag IndexArrayOp = 331 -primOpTag UnsafeFreezeArrayOp = 332 -primOpTag UnsafeThawArrayOp = 333 -primOpTag CopyArrayOp = 334 -primOpTag CopyMutableArrayOp = 335 -primOpTag CloneArrayOp = 336 -primOpTag CloneMutableArrayOp = 337 -primOpTag FreezeArrayOp = 338 -primOpTag ThawArrayOp = 339 -primOpTag CasArrayOp = 340 -primOpTag NewSmallArrayOp = 341 -primOpTag ShrinkSmallMutableArrayOp_Char = 342 -primOpTag ReadSmallArrayOp = 343 -primOpTag WriteSmallArrayOp = 344 -primOpTag SizeofSmallArrayOp = 345 -primOpTag SizeofSmallMutableArrayOp = 346 -primOpTag GetSizeofSmallMutableArrayOp = 347 -primOpTag IndexSmallArrayOp = 348 -primOpTag UnsafeFreezeSmallArrayOp = 349 -primOpTag UnsafeThawSmallArrayOp = 350 -primOpTag CopySmallArrayOp = 351 -primOpTag CopySmallMutableArrayOp = 352 -primOpTag CloneSmallArrayOp = 353 -primOpTag CloneSmallMutableArrayOp = 354 -primOpTag FreezeSmallArrayOp = 355 -primOpTag ThawSmallArrayOp = 356 -primOpTag CasSmallArrayOp = 357 -primOpTag NewByteArrayOp_Char = 358 -primOpTag NewPinnedByteArrayOp_Char = 359 -primOpTag NewAlignedPinnedByteArrayOp_Char = 360 -primOpTag MutableByteArrayIsPinnedOp = 361 -primOpTag ByteArrayIsPinnedOp = 362 -primOpTag ByteArrayContents_Char = 363 -primOpTag MutableByteArrayContents_Char = 364 -primOpTag ShrinkMutableByteArrayOp_Char = 365 -primOpTag ResizeMutableByteArrayOp_Char = 366 -primOpTag UnsafeFreezeByteArrayOp = 367 -primOpTag SizeofByteArrayOp = 368 -primOpTag SizeofMutableByteArrayOp = 369 -primOpTag GetSizeofMutableByteArrayOp = 370 -primOpTag IndexByteArrayOp_Char = 371 -primOpTag IndexByteArrayOp_WideChar = 372 -primOpTag IndexByteArrayOp_Int = 373 -primOpTag IndexByteArrayOp_Word = 374 -primOpTag IndexByteArrayOp_Addr = 375 -primOpTag IndexByteArrayOp_Float = 376 -primOpTag IndexByteArrayOp_Double = 377 -primOpTag IndexByteArrayOp_StablePtr = 378 -primOpTag IndexByteArrayOp_Int8 = 379 -primOpTag IndexByteArrayOp_Int16 = 380 -primOpTag IndexByteArrayOp_Int32 = 381 -primOpTag IndexByteArrayOp_Int64 = 382 -primOpTag IndexByteArrayOp_Word8 = 383 -primOpTag IndexByteArrayOp_Word16 = 384 -primOpTag IndexByteArrayOp_Word32 = 385 -primOpTag IndexByteArrayOp_Word64 = 386 -primOpTag IndexByteArrayOp_Word8AsChar = 387 -primOpTag IndexByteArrayOp_Word8AsWideChar = 388 -primOpTag IndexByteArrayOp_Word8AsInt = 389 -primOpTag IndexByteArrayOp_Word8AsWord = 390 -primOpTag IndexByteArrayOp_Word8AsAddr = 391 -primOpTag IndexByteArrayOp_Word8AsFloat = 392 -primOpTag IndexByteArrayOp_Word8AsDouble = 393 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 394 -primOpTag IndexByteArrayOp_Word8AsInt16 = 395 -primOpTag IndexByteArrayOp_Word8AsInt32 = 396 -primOpTag IndexByteArrayOp_Word8AsInt64 = 397 -primOpTag IndexByteArrayOp_Word8AsWord16 = 398 -primOpTag IndexByteArrayOp_Word8AsWord32 = 399 -primOpTag IndexByteArrayOp_Word8AsWord64 = 400 -primOpTag ReadByteArrayOp_Char = 401 -primOpTag ReadByteArrayOp_WideChar = 402 -primOpTag ReadByteArrayOp_Int = 403 -primOpTag ReadByteArrayOp_Word = 404 -primOpTag ReadByteArrayOp_Addr = 405 -primOpTag ReadByteArrayOp_Float = 406 -primOpTag ReadByteArrayOp_Double = 407 -primOpTag ReadByteArrayOp_StablePtr = 408 -primOpTag ReadByteArrayOp_Int8 = 409 -primOpTag ReadByteArrayOp_Int16 = 410 -primOpTag ReadByteArrayOp_Int32 = 411 -primOpTag ReadByteArrayOp_Int64 = 412 -primOpTag ReadByteArrayOp_Word8 = 413 -primOpTag ReadByteArrayOp_Word16 = 414 -primOpTag ReadByteArrayOp_Word32 = 415 -primOpTag ReadByteArrayOp_Word64 = 416 -primOpTag ReadByteArrayOp_Word8AsChar = 417 -primOpTag ReadByteArrayOp_Word8AsWideChar = 418 -primOpTag ReadByteArrayOp_Word8AsInt = 419 -primOpTag ReadByteArrayOp_Word8AsWord = 420 -primOpTag ReadByteArrayOp_Word8AsAddr = 421 -primOpTag ReadByteArrayOp_Word8AsFloat = 422 -primOpTag ReadByteArrayOp_Word8AsDouble = 423 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 424 -primOpTag ReadByteArrayOp_Word8AsInt16 = 425 -primOpTag ReadByteArrayOp_Word8AsInt32 = 426 -primOpTag ReadByteArrayOp_Word8AsInt64 = 427 -primOpTag ReadByteArrayOp_Word8AsWord16 = 428 -primOpTag ReadByteArrayOp_Word8AsWord32 = 429 -primOpTag ReadByteArrayOp_Word8AsWord64 = 430 -primOpTag WriteByteArrayOp_Char = 431 -primOpTag WriteByteArrayOp_WideChar = 432 -primOpTag WriteByteArrayOp_Int = 433 -primOpTag WriteByteArrayOp_Word = 434 -primOpTag WriteByteArrayOp_Addr = 435 -primOpTag WriteByteArrayOp_Float = 436 -primOpTag WriteByteArrayOp_Double = 437 -primOpTag WriteByteArrayOp_StablePtr = 438 -primOpTag WriteByteArrayOp_Int8 = 439 -primOpTag WriteByteArrayOp_Int16 = 440 -primOpTag WriteByteArrayOp_Int32 = 441 -primOpTag WriteByteArrayOp_Int64 = 442 -primOpTag WriteByteArrayOp_Word8 = 443 -primOpTag WriteByteArrayOp_Word16 = 444 -primOpTag WriteByteArrayOp_Word32 = 445 -primOpTag WriteByteArrayOp_Word64 = 446 -primOpTag WriteByteArrayOp_Word8AsChar = 447 -primOpTag WriteByteArrayOp_Word8AsWideChar = 448 -primOpTag WriteByteArrayOp_Word8AsInt = 449 -primOpTag WriteByteArrayOp_Word8AsWord = 450 -primOpTag WriteByteArrayOp_Word8AsAddr = 451 -primOpTag WriteByteArrayOp_Word8AsFloat = 452 -primOpTag WriteByteArrayOp_Word8AsDouble = 453 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 454 -primOpTag WriteByteArrayOp_Word8AsInt16 = 455 -primOpTag WriteByteArrayOp_Word8AsInt32 = 456 -primOpTag WriteByteArrayOp_Word8AsInt64 = 457 -primOpTag WriteByteArrayOp_Word8AsWord16 = 458 -primOpTag WriteByteArrayOp_Word8AsWord32 = 459 -primOpTag WriteByteArrayOp_Word8AsWord64 = 460 -primOpTag CompareByteArraysOp = 461 -primOpTag CopyByteArrayOp = 462 -primOpTag CopyMutableByteArrayOp = 463 -primOpTag CopyByteArrayToAddrOp = 464 -primOpTag CopyMutableByteArrayToAddrOp = 465 -primOpTag CopyAddrToByteArrayOp = 466 -primOpTag SetByteArrayOp = 467 -primOpTag AtomicReadByteArrayOp_Int = 468 -primOpTag AtomicWriteByteArrayOp_Int = 469 -primOpTag CasByteArrayOp_Int = 470 -primOpTag CasByteArrayOp_Int8 = 471 -primOpTag CasByteArrayOp_Int16 = 472 -primOpTag CasByteArrayOp_Int32 = 473 -primOpTag CasByteArrayOp_Int64 = 474 -primOpTag FetchAddByteArrayOp_Int = 475 -primOpTag FetchSubByteArrayOp_Int = 476 -primOpTag FetchAndByteArrayOp_Int = 477 -primOpTag FetchNandByteArrayOp_Int = 478 -primOpTag FetchOrByteArrayOp_Int = 479 -primOpTag FetchXorByteArrayOp_Int = 480 -primOpTag AddrAddOp = 481 -primOpTag AddrSubOp = 482 -primOpTag AddrRemOp = 483 -primOpTag AddrToIntOp = 484 -primOpTag IntToAddrOp = 485 -primOpTag AddrGtOp = 486 -primOpTag AddrGeOp = 487 -primOpTag AddrEqOp = 488 -primOpTag AddrNeOp = 489 -primOpTag AddrLtOp = 490 -primOpTag AddrLeOp = 491 -primOpTag IndexOffAddrOp_Char = 492 -primOpTag IndexOffAddrOp_WideChar = 493 -primOpTag IndexOffAddrOp_Int = 494 -primOpTag IndexOffAddrOp_Word = 495 -primOpTag IndexOffAddrOp_Addr = 496 -primOpTag IndexOffAddrOp_Float = 497 -primOpTag IndexOffAddrOp_Double = 498 -primOpTag IndexOffAddrOp_StablePtr = 499 -primOpTag IndexOffAddrOp_Int8 = 500 -primOpTag IndexOffAddrOp_Int16 = 501 -primOpTag IndexOffAddrOp_Int32 = 502 -primOpTag IndexOffAddrOp_Int64 = 503 -primOpTag IndexOffAddrOp_Word8 = 504 -primOpTag IndexOffAddrOp_Word16 = 505 -primOpTag IndexOffAddrOp_Word32 = 506 -primOpTag IndexOffAddrOp_Word64 = 507 -primOpTag ReadOffAddrOp_Char = 508 -primOpTag ReadOffAddrOp_WideChar = 509 -primOpTag ReadOffAddrOp_Int = 510 -primOpTag ReadOffAddrOp_Word = 511 -primOpTag ReadOffAddrOp_Addr = 512 -primOpTag ReadOffAddrOp_Float = 513 -primOpTag ReadOffAddrOp_Double = 514 -primOpTag ReadOffAddrOp_StablePtr = 515 -primOpTag ReadOffAddrOp_Int8 = 516 -primOpTag ReadOffAddrOp_Int16 = 517 -primOpTag ReadOffAddrOp_Int32 = 518 -primOpTag ReadOffAddrOp_Int64 = 519 -primOpTag ReadOffAddrOp_Word8 = 520 -primOpTag ReadOffAddrOp_Word16 = 521 -primOpTag ReadOffAddrOp_Word32 = 522 -primOpTag ReadOffAddrOp_Word64 = 523 -primOpTag WriteOffAddrOp_Char = 524 -primOpTag WriteOffAddrOp_WideChar = 525 -primOpTag WriteOffAddrOp_Int = 526 -primOpTag WriteOffAddrOp_Word = 527 -primOpTag WriteOffAddrOp_Addr = 528 -primOpTag WriteOffAddrOp_Float = 529 -primOpTag WriteOffAddrOp_Double = 530 -primOpTag WriteOffAddrOp_StablePtr = 531 -primOpTag WriteOffAddrOp_Int8 = 532 -primOpTag WriteOffAddrOp_Int16 = 533 -primOpTag WriteOffAddrOp_Int32 = 534 -primOpTag WriteOffAddrOp_Int64 = 535 -primOpTag WriteOffAddrOp_Word8 = 536 -primOpTag WriteOffAddrOp_Word16 = 537 -primOpTag WriteOffAddrOp_Word32 = 538 -primOpTag WriteOffAddrOp_Word64 = 539 -primOpTag InterlockedExchange_Addr = 540 -primOpTag InterlockedExchange_Word = 541 -primOpTag CasAddrOp_Addr = 542 -primOpTag CasAddrOp_Word = 543 -primOpTag CasAddrOp_Word8 = 544 -primOpTag CasAddrOp_Word16 = 545 -primOpTag CasAddrOp_Word32 = 546 -primOpTag CasAddrOp_Word64 = 547 -primOpTag FetchAddAddrOp_Word = 548 -primOpTag FetchSubAddrOp_Word = 549 -primOpTag FetchAndAddrOp_Word = 550 -primOpTag FetchNandAddrOp_Word = 551 -primOpTag FetchOrAddrOp_Word = 552 -primOpTag FetchXorAddrOp_Word = 553 -primOpTag AtomicReadAddrOp_Word = 554 -primOpTag AtomicWriteAddrOp_Word = 555 -primOpTag NewMutVarOp = 556 -primOpTag ReadMutVarOp = 557 -primOpTag WriteMutVarOp = 558 -primOpTag AtomicModifyMutVar2Op = 559 -primOpTag AtomicModifyMutVar_Op = 560 -primOpTag CasMutVarOp = 561 -primOpTag CatchOp = 562 -primOpTag RaiseOp = 563 -primOpTag RaiseIOOp = 564 -primOpTag MaskAsyncExceptionsOp = 565 -primOpTag MaskUninterruptibleOp = 566 -primOpTag UnmaskAsyncExceptionsOp = 567 -primOpTag MaskStatus = 568 -primOpTag AtomicallyOp = 569 -primOpTag RetryOp = 570 -primOpTag CatchRetryOp = 571 -primOpTag CatchSTMOp = 572 -primOpTag NewTVarOp = 573 -primOpTag ReadTVarOp = 574 -primOpTag ReadTVarIOOp = 575 -primOpTag WriteTVarOp = 576 -primOpTag NewMVarOp = 577 -primOpTag TakeMVarOp = 578 -primOpTag TryTakeMVarOp = 579 -primOpTag PutMVarOp = 580 -primOpTag TryPutMVarOp = 581 -primOpTag ReadMVarOp = 582 -primOpTag TryReadMVarOp = 583 -primOpTag IsEmptyMVarOp = 584 -primOpTag NewIOPortOp = 585 -primOpTag ReadIOPortOp = 586 -primOpTag WriteIOPortOp = 587 -primOpTag DelayOp = 588 -primOpTag WaitReadOp = 589 -primOpTag WaitWriteOp = 590 -primOpTag ForkOp = 591 -primOpTag ForkOnOp = 592 -primOpTag KillThreadOp = 593 -primOpTag YieldOp = 594 -primOpTag MyThreadIdOp = 595 -primOpTag LabelThreadOp = 596 -primOpTag IsCurrentThreadBoundOp = 597 -primOpTag NoDuplicateOp = 598 -primOpTag ThreadStatusOp = 599 -primOpTag MkWeakOp = 600 -primOpTag MkWeakNoFinalizerOp = 601 -primOpTag AddCFinalizerToWeakOp = 602 -primOpTag DeRefWeakOp = 603 -primOpTag FinalizeWeakOp = 604 -primOpTag TouchOp = 605 -primOpTag MakeStablePtrOp = 606 -primOpTag DeRefStablePtrOp = 607 -primOpTag EqStablePtrOp = 608 -primOpTag MakeStableNameOp = 609 -primOpTag StableNameToIntOp = 610 -primOpTag CompactNewOp = 611 -primOpTag CompactResizeOp = 612 -primOpTag CompactContainsOp = 613 -primOpTag CompactContainsAnyOp = 614 -primOpTag CompactGetFirstBlockOp = 615 -primOpTag CompactGetNextBlockOp = 616 -primOpTag CompactAllocateBlockOp = 617 -primOpTag CompactFixupPointersOp = 618 -primOpTag CompactAdd = 619 -primOpTag CompactAddWithSharing = 620 -primOpTag CompactSize = 621 -primOpTag ReallyUnsafePtrEqualityOp = 622 -primOpTag ParOp = 623 -primOpTag SparkOp = 624 -primOpTag SeqOp = 625 -primOpTag GetSparkOp = 626 -primOpTag NumSparks = 627 -primOpTag KeepAliveOp = 628 -primOpTag DataToTagOp = 629 -primOpTag TagToEnumOp = 630 -primOpTag AddrToAnyOp = 631 -primOpTag AnyToAddrOp = 632 -primOpTag MkApUpd0_Op = 633 -primOpTag NewBCOOp = 634 -primOpTag UnpackClosureOp = 635 -primOpTag ClosureSizeOp = 636 -primOpTag GetApStackValOp = 637 -primOpTag GetCCSOfOp = 638 -primOpTag GetCurrentCCSOp = 639 -primOpTag ClearCCSOp = 640 -primOpTag WhereFromOp = 641 -primOpTag TraceEventOp = 642 -primOpTag TraceEventBinaryOp = 643 -primOpTag TraceMarkerOp = 644 -primOpTag SetThreadAllocationCounter = 645 -primOpTag (VecBroadcastOp IntVec 16 W8) = 646 -primOpTag (VecBroadcastOp IntVec 8 W16) = 647 -primOpTag (VecBroadcastOp IntVec 4 W32) = 648 -primOpTag (VecBroadcastOp IntVec 2 W64) = 649 -primOpTag (VecBroadcastOp IntVec 32 W8) = 650 -primOpTag (VecBroadcastOp IntVec 16 W16) = 651 -primOpTag (VecBroadcastOp IntVec 8 W32) = 652 -primOpTag (VecBroadcastOp IntVec 4 W64) = 653 -primOpTag (VecBroadcastOp IntVec 64 W8) = 654 -primOpTag (VecBroadcastOp IntVec 32 W16) = 655 -primOpTag (VecBroadcastOp IntVec 16 W32) = 656 -primOpTag (VecBroadcastOp IntVec 8 W64) = 657 -primOpTag (VecBroadcastOp WordVec 16 W8) = 658 -primOpTag (VecBroadcastOp WordVec 8 W16) = 659 -primOpTag (VecBroadcastOp WordVec 4 W32) = 660 -primOpTag (VecBroadcastOp WordVec 2 W64) = 661 -primOpTag (VecBroadcastOp WordVec 32 W8) = 662 -primOpTag (VecBroadcastOp WordVec 16 W16) = 663 -primOpTag (VecBroadcastOp WordVec 8 W32) = 664 -primOpTag (VecBroadcastOp WordVec 4 W64) = 665 -primOpTag (VecBroadcastOp WordVec 64 W8) = 666 -primOpTag (VecBroadcastOp WordVec 32 W16) = 667 -primOpTag (VecBroadcastOp WordVec 16 W32) = 668 -primOpTag (VecBroadcastOp WordVec 8 W64) = 669 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 670 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 671 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 672 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 673 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 674 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 675 -primOpTag (VecPackOp IntVec 16 W8) = 676 -primOpTag (VecPackOp IntVec 8 W16) = 677 -primOpTag (VecPackOp IntVec 4 W32) = 678 -primOpTag (VecPackOp IntVec 2 W64) = 679 -primOpTag (VecPackOp IntVec 32 W8) = 680 -primOpTag (VecPackOp IntVec 16 W16) = 681 -primOpTag (VecPackOp IntVec 8 W32) = 682 -primOpTag (VecPackOp IntVec 4 W64) = 683 -primOpTag (VecPackOp IntVec 64 W8) = 684 -primOpTag (VecPackOp IntVec 32 W16) = 685 -primOpTag (VecPackOp IntVec 16 W32) = 686 -primOpTag (VecPackOp IntVec 8 W64) = 687 -primOpTag (VecPackOp WordVec 16 W8) = 688 -primOpTag (VecPackOp WordVec 8 W16) = 689 -primOpTag (VecPackOp WordVec 4 W32) = 690 -primOpTag (VecPackOp WordVec 2 W64) = 691 -primOpTag (VecPackOp WordVec 32 W8) = 692 -primOpTag (VecPackOp WordVec 16 W16) = 693 -primOpTag (VecPackOp WordVec 8 W32) = 694 -primOpTag (VecPackOp WordVec 4 W64) = 695 -primOpTag (VecPackOp WordVec 64 W8) = 696 -primOpTag (VecPackOp WordVec 32 W16) = 697 -primOpTag (VecPackOp WordVec 16 W32) = 698 -primOpTag (VecPackOp WordVec 8 W64) = 699 -primOpTag (VecPackOp FloatVec 4 W32) = 700 -primOpTag (VecPackOp FloatVec 2 W64) = 701 -primOpTag (VecPackOp FloatVec 8 W32) = 702 -primOpTag (VecPackOp FloatVec 4 W64) = 703 -primOpTag (VecPackOp FloatVec 16 W32) = 704 -primOpTag (VecPackOp FloatVec 8 W64) = 705 -primOpTag (VecUnpackOp IntVec 16 W8) = 706 -primOpTag (VecUnpackOp IntVec 8 W16) = 707 -primOpTag (VecUnpackOp IntVec 4 W32) = 708 -primOpTag (VecUnpackOp IntVec 2 W64) = 709 -primOpTag (VecUnpackOp IntVec 32 W8) = 710 -primOpTag (VecUnpackOp IntVec 16 W16) = 711 -primOpTag (VecUnpackOp IntVec 8 W32) = 712 -primOpTag (VecUnpackOp IntVec 4 W64) = 713 -primOpTag (VecUnpackOp IntVec 64 W8) = 714 -primOpTag (VecUnpackOp IntVec 32 W16) = 715 -primOpTag (VecUnpackOp IntVec 16 W32) = 716 -primOpTag (VecUnpackOp IntVec 8 W64) = 717 -primOpTag (VecUnpackOp WordVec 16 W8) = 718 -primOpTag (VecUnpackOp WordVec 8 W16) = 719 -primOpTag (VecUnpackOp WordVec 4 W32) = 720 -primOpTag (VecUnpackOp WordVec 2 W64) = 721 -primOpTag (VecUnpackOp WordVec 32 W8) = 722 -primOpTag (VecUnpackOp WordVec 16 W16) = 723 -primOpTag (VecUnpackOp WordVec 8 W32) = 724 -primOpTag (VecUnpackOp WordVec 4 W64) = 725 -primOpTag (VecUnpackOp WordVec 64 W8) = 726 -primOpTag (VecUnpackOp WordVec 32 W16) = 727 -primOpTag (VecUnpackOp WordVec 16 W32) = 728 -primOpTag (VecUnpackOp WordVec 8 W64) = 729 -primOpTag (VecUnpackOp FloatVec 4 W32) = 730 -primOpTag (VecUnpackOp FloatVec 2 W64) = 731 -primOpTag (VecUnpackOp FloatVec 8 W32) = 732 -primOpTag (VecUnpackOp FloatVec 4 W64) = 733 -primOpTag (VecUnpackOp FloatVec 16 W32) = 734 -primOpTag (VecUnpackOp FloatVec 8 W64) = 735 -primOpTag (VecInsertOp IntVec 16 W8) = 736 -primOpTag (VecInsertOp IntVec 8 W16) = 737 -primOpTag (VecInsertOp IntVec 4 W32) = 738 -primOpTag (VecInsertOp IntVec 2 W64) = 739 -primOpTag (VecInsertOp IntVec 32 W8) = 740 -primOpTag (VecInsertOp IntVec 16 W16) = 741 -primOpTag (VecInsertOp IntVec 8 W32) = 742 -primOpTag (VecInsertOp IntVec 4 W64) = 743 -primOpTag (VecInsertOp IntVec 64 W8) = 744 -primOpTag (VecInsertOp IntVec 32 W16) = 745 -primOpTag (VecInsertOp IntVec 16 W32) = 746 -primOpTag (VecInsertOp IntVec 8 W64) = 747 -primOpTag (VecInsertOp WordVec 16 W8) = 748 -primOpTag (VecInsertOp WordVec 8 W16) = 749 -primOpTag (VecInsertOp WordVec 4 W32) = 750 -primOpTag (VecInsertOp WordVec 2 W64) = 751 -primOpTag (VecInsertOp WordVec 32 W8) = 752 -primOpTag (VecInsertOp WordVec 16 W16) = 753 -primOpTag (VecInsertOp WordVec 8 W32) = 754 -primOpTag (VecInsertOp WordVec 4 W64) = 755 -primOpTag (VecInsertOp WordVec 64 W8) = 756 -primOpTag (VecInsertOp WordVec 32 W16) = 757 -primOpTag (VecInsertOp WordVec 16 W32) = 758 -primOpTag (VecInsertOp WordVec 8 W64) = 759 -primOpTag (VecInsertOp FloatVec 4 W32) = 760 -primOpTag (VecInsertOp FloatVec 2 W64) = 761 -primOpTag (VecInsertOp FloatVec 8 W32) = 762 -primOpTag (VecInsertOp FloatVec 4 W64) = 763 -primOpTag (VecInsertOp FloatVec 16 W32) = 764 -primOpTag (VecInsertOp FloatVec 8 W64) = 765 -primOpTag (VecAddOp IntVec 16 W8) = 766 -primOpTag (VecAddOp IntVec 8 W16) = 767 -primOpTag (VecAddOp IntVec 4 W32) = 768 -primOpTag (VecAddOp IntVec 2 W64) = 769 -primOpTag (VecAddOp IntVec 32 W8) = 770 -primOpTag (VecAddOp IntVec 16 W16) = 771 -primOpTag (VecAddOp IntVec 8 W32) = 772 -primOpTag (VecAddOp IntVec 4 W64) = 773 -primOpTag (VecAddOp IntVec 64 W8) = 774 -primOpTag (VecAddOp IntVec 32 W16) = 775 -primOpTag (VecAddOp IntVec 16 W32) = 776 -primOpTag (VecAddOp IntVec 8 W64) = 777 -primOpTag (VecAddOp WordVec 16 W8) = 778 -primOpTag (VecAddOp WordVec 8 W16) = 779 -primOpTag (VecAddOp WordVec 4 W32) = 780 -primOpTag (VecAddOp WordVec 2 W64) = 781 -primOpTag (VecAddOp WordVec 32 W8) = 782 -primOpTag (VecAddOp WordVec 16 W16) = 783 -primOpTag (VecAddOp WordVec 8 W32) = 784 -primOpTag (VecAddOp WordVec 4 W64) = 785 -primOpTag (VecAddOp WordVec 64 W8) = 786 -primOpTag (VecAddOp WordVec 32 W16) = 787 -primOpTag (VecAddOp WordVec 16 W32) = 788 -primOpTag (VecAddOp WordVec 8 W64) = 789 -primOpTag (VecAddOp FloatVec 4 W32) = 790 -primOpTag (VecAddOp FloatVec 2 W64) = 791 -primOpTag (VecAddOp FloatVec 8 W32) = 792 -primOpTag (VecAddOp FloatVec 4 W64) = 793 -primOpTag (VecAddOp FloatVec 16 W32) = 794 -primOpTag (VecAddOp FloatVec 8 W64) = 795 -primOpTag (VecSubOp IntVec 16 W8) = 796 -primOpTag (VecSubOp IntVec 8 W16) = 797 -primOpTag (VecSubOp IntVec 4 W32) = 798 -primOpTag (VecSubOp IntVec 2 W64) = 799 -primOpTag (VecSubOp IntVec 32 W8) = 800 -primOpTag (VecSubOp IntVec 16 W16) = 801 -primOpTag (VecSubOp IntVec 8 W32) = 802 -primOpTag (VecSubOp IntVec 4 W64) = 803 -primOpTag (VecSubOp IntVec 64 W8) = 804 -primOpTag (VecSubOp IntVec 32 W16) = 805 -primOpTag (VecSubOp IntVec 16 W32) = 806 -primOpTag (VecSubOp IntVec 8 W64) = 807 -primOpTag (VecSubOp WordVec 16 W8) = 808 -primOpTag (VecSubOp WordVec 8 W16) = 809 -primOpTag (VecSubOp WordVec 4 W32) = 810 -primOpTag (VecSubOp WordVec 2 W64) = 811 -primOpTag (VecSubOp WordVec 32 W8) = 812 -primOpTag (VecSubOp WordVec 16 W16) = 813 -primOpTag (VecSubOp WordVec 8 W32) = 814 -primOpTag (VecSubOp WordVec 4 W64) = 815 -primOpTag (VecSubOp WordVec 64 W8) = 816 -primOpTag (VecSubOp WordVec 32 W16) = 817 -primOpTag (VecSubOp WordVec 16 W32) = 818 -primOpTag (VecSubOp WordVec 8 W64) = 819 -primOpTag (VecSubOp FloatVec 4 W32) = 820 -primOpTag (VecSubOp FloatVec 2 W64) = 821 -primOpTag (VecSubOp FloatVec 8 W32) = 822 -primOpTag (VecSubOp FloatVec 4 W64) = 823 -primOpTag (VecSubOp FloatVec 16 W32) = 824 -primOpTag (VecSubOp FloatVec 8 W64) = 825 -primOpTag (VecMulOp IntVec 16 W8) = 826 -primOpTag (VecMulOp IntVec 8 W16) = 827 -primOpTag (VecMulOp IntVec 4 W32) = 828 -primOpTag (VecMulOp IntVec 2 W64) = 829 -primOpTag (VecMulOp IntVec 32 W8) = 830 -primOpTag (VecMulOp IntVec 16 W16) = 831 -primOpTag (VecMulOp IntVec 8 W32) = 832 -primOpTag (VecMulOp IntVec 4 W64) = 833 -primOpTag (VecMulOp IntVec 64 W8) = 834 -primOpTag (VecMulOp IntVec 32 W16) = 835 -primOpTag (VecMulOp IntVec 16 W32) = 836 -primOpTag (VecMulOp IntVec 8 W64) = 837 -primOpTag (VecMulOp WordVec 16 W8) = 838 -primOpTag (VecMulOp WordVec 8 W16) = 839 -primOpTag (VecMulOp WordVec 4 W32) = 840 -primOpTag (VecMulOp WordVec 2 W64) = 841 -primOpTag (VecMulOp WordVec 32 W8) = 842 -primOpTag (VecMulOp WordVec 16 W16) = 843 -primOpTag (VecMulOp WordVec 8 W32) = 844 -primOpTag (VecMulOp WordVec 4 W64) = 845 -primOpTag (VecMulOp WordVec 64 W8) = 846 -primOpTag (VecMulOp WordVec 32 W16) = 847 -primOpTag (VecMulOp WordVec 16 W32) = 848 -primOpTag (VecMulOp WordVec 8 W64) = 849 -primOpTag (VecMulOp FloatVec 4 W32) = 850 -primOpTag (VecMulOp FloatVec 2 W64) = 851 -primOpTag (VecMulOp FloatVec 8 W32) = 852 -primOpTag (VecMulOp FloatVec 4 W64) = 853 -primOpTag (VecMulOp FloatVec 16 W32) = 854 -primOpTag (VecMulOp FloatVec 8 W64) = 855 -primOpTag (VecDivOp FloatVec 4 W32) = 856 -primOpTag (VecDivOp FloatVec 2 W64) = 857 -primOpTag (VecDivOp FloatVec 8 W32) = 858 -primOpTag (VecDivOp FloatVec 4 W64) = 859 -primOpTag (VecDivOp FloatVec 16 W32) = 860 -primOpTag (VecDivOp FloatVec 8 W64) = 861 -primOpTag (VecQuotOp IntVec 16 W8) = 862 -primOpTag (VecQuotOp IntVec 8 W16) = 863 -primOpTag (VecQuotOp IntVec 4 W32) = 864 -primOpTag (VecQuotOp IntVec 2 W64) = 865 -primOpTag (VecQuotOp IntVec 32 W8) = 866 -primOpTag (VecQuotOp IntVec 16 W16) = 867 -primOpTag (VecQuotOp IntVec 8 W32) = 868 -primOpTag (VecQuotOp IntVec 4 W64) = 869 -primOpTag (VecQuotOp IntVec 64 W8) = 870 -primOpTag (VecQuotOp IntVec 32 W16) = 871 -primOpTag (VecQuotOp IntVec 16 W32) = 872 -primOpTag (VecQuotOp IntVec 8 W64) = 873 -primOpTag (VecQuotOp WordVec 16 W8) = 874 -primOpTag (VecQuotOp WordVec 8 W16) = 875 -primOpTag (VecQuotOp WordVec 4 W32) = 876 -primOpTag (VecQuotOp WordVec 2 W64) = 877 -primOpTag (VecQuotOp WordVec 32 W8) = 878 -primOpTag (VecQuotOp WordVec 16 W16) = 879 -primOpTag (VecQuotOp WordVec 8 W32) = 880 -primOpTag (VecQuotOp WordVec 4 W64) = 881 -primOpTag (VecQuotOp WordVec 64 W8) = 882 -primOpTag (VecQuotOp WordVec 32 W16) = 883 -primOpTag (VecQuotOp WordVec 16 W32) = 884 -primOpTag (VecQuotOp WordVec 8 W64) = 885 -primOpTag (VecRemOp IntVec 16 W8) = 886 -primOpTag (VecRemOp IntVec 8 W16) = 887 -primOpTag (VecRemOp IntVec 4 W32) = 888 -primOpTag (VecRemOp IntVec 2 W64) = 889 -primOpTag (VecRemOp IntVec 32 W8) = 890 -primOpTag (VecRemOp IntVec 16 W16) = 891 -primOpTag (VecRemOp IntVec 8 W32) = 892 -primOpTag (VecRemOp IntVec 4 W64) = 893 -primOpTag (VecRemOp IntVec 64 W8) = 894 -primOpTag (VecRemOp IntVec 32 W16) = 895 -primOpTag (VecRemOp IntVec 16 W32) = 896 -primOpTag (VecRemOp IntVec 8 W64) = 897 -primOpTag (VecRemOp WordVec 16 W8) = 898 -primOpTag (VecRemOp WordVec 8 W16) = 899 -primOpTag (VecRemOp WordVec 4 W32) = 900 -primOpTag (VecRemOp WordVec 2 W64) = 901 -primOpTag (VecRemOp WordVec 32 W8) = 902 -primOpTag (VecRemOp WordVec 16 W16) = 903 -primOpTag (VecRemOp WordVec 8 W32) = 904 -primOpTag (VecRemOp WordVec 4 W64) = 905 -primOpTag (VecRemOp WordVec 64 W8) = 906 -primOpTag (VecRemOp WordVec 32 W16) = 907 -primOpTag (VecRemOp WordVec 16 W32) = 908 -primOpTag (VecRemOp WordVec 8 W64) = 909 -primOpTag (VecNegOp IntVec 16 W8) = 910 -primOpTag (VecNegOp IntVec 8 W16) = 911 -primOpTag (VecNegOp IntVec 4 W32) = 912 -primOpTag (VecNegOp IntVec 2 W64) = 913 -primOpTag (VecNegOp IntVec 32 W8) = 914 -primOpTag (VecNegOp IntVec 16 W16) = 915 -primOpTag (VecNegOp IntVec 8 W32) = 916 -primOpTag (VecNegOp IntVec 4 W64) = 917 -primOpTag (VecNegOp IntVec 64 W8) = 918 -primOpTag (VecNegOp IntVec 32 W16) = 919 -primOpTag (VecNegOp IntVec 16 W32) = 920 -primOpTag (VecNegOp IntVec 8 W64) = 921 -primOpTag (VecNegOp FloatVec 4 W32) = 922 -primOpTag (VecNegOp FloatVec 2 W64) = 923 -primOpTag (VecNegOp FloatVec 8 W32) = 924 -primOpTag (VecNegOp FloatVec 4 W64) = 925 -primOpTag (VecNegOp FloatVec 16 W32) = 926 -primOpTag (VecNegOp FloatVec 8 W64) = 927 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 928 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 929 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 930 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 931 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 932 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 933 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 934 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 935 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 936 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 937 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 938 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 939 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 940 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 941 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 942 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 943 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 944 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 945 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 946 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 947 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 948 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 949 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 950 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 951 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 952 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 953 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 954 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 955 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 956 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 957 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 958 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 959 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 960 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 961 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 962 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 963 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 964 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 965 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 966 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 967 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 968 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 969 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 970 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 971 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 972 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 973 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 974 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 975 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 976 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 977 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 978 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 979 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 980 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 981 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 982 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 983 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 984 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 985 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 986 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 987 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 988 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 989 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 990 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 991 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 992 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 993 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 994 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 995 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 996 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 997 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 998 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 999 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1000 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1001 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1002 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1003 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1004 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1005 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1006 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1007 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1008 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1009 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1010 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1011 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1012 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1013 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1014 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1015 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1016 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1017 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1018 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1019 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1020 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1021 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1022 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1023 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1024 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1025 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1026 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1027 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1028 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1029 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1030 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1031 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1032 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1033 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1034 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1035 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1036 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1037 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1038 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1039 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1040 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1041 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1042 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1043 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1044 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1045 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1046 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1047 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1048 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1049 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1050 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1051 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1052 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1053 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1054 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1055 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1056 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1057 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1058 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1059 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1060 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1061 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1062 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1063 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1064 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1065 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1066 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1067 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1068 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1069 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1070 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1071 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1072 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1073 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1074 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1075 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1076 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1077 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1078 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1079 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1080 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1081 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1082 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1083 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1084 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1085 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1086 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1087 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1088 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1089 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1090 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1091 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1092 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1093 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1094 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1095 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1096 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1097 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1098 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1099 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1100 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1101 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1102 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1103 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1104 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1105 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1106 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1107 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1108 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1109 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1110 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1111 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1112 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1113 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1114 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1115 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1116 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1117 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1118 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1119 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1120 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1121 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1122 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1123 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1124 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1125 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1126 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1127 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1128 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1129 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1130 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1131 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1132 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1133 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1134 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1135 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1136 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1137 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1138 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1139 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1140 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1141 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1142 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1143 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1144 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1145 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1146 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1147 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1148 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1149 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1150 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1151 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1152 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1153 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1154 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1155 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1156 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1157 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1158 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1159 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1160 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1161 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1162 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1163 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1164 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1165 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1166 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1167 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1168 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1169 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1170 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1171 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1172 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1173 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1174 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1175 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1176 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1177 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1178 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1179 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1180 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1181 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1182 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1183 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1184 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1185 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1186 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1187 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1188 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1189 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1190 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1191 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1192 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1193 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1194 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1195 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1196 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1197 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1198 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1199 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1200 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1201 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1202 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1203 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1204 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1205 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1206 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1207 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1208 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1209 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1210 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1211 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1212 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1213 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1214 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1215 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1216 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1217 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1218 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1219 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1220 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1221 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1222 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1223 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1224 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1225 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1226 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1227 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1228 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1229 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1230 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1231 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1232 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1233 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1234 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1235 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1236 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1237 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1238 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1239 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1240 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1241 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1242 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1243 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1244 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1245 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1246 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1247 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1248 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1249 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1250 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1251 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1252 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1253 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1254 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1255 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1256 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1257 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1258 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1259 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1260 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1261 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1262 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1263 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1264 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1265 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1266 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1267 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1268 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1269 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1270 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1271 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1272 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1273 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1274 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1275 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1276 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1277 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1278 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1279 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1280 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1281 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1282 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1283 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1284 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1285 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1286 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1287 -primOpTag PrefetchByteArrayOp3 = 1288 -primOpTag PrefetchMutableByteArrayOp3 = 1289 -primOpTag PrefetchAddrOp3 = 1290 -primOpTag PrefetchValueOp3 = 1291 -primOpTag PrefetchByteArrayOp2 = 1292 -primOpTag PrefetchMutableByteArrayOp2 = 1293 -primOpTag PrefetchAddrOp2 = 1294 -primOpTag PrefetchValueOp2 = 1295 -primOpTag PrefetchByteArrayOp1 = 1296 -primOpTag PrefetchMutableByteArrayOp1 = 1297 -primOpTag PrefetchAddrOp1 = 1298 -primOpTag PrefetchValueOp1 = 1299 -primOpTag PrefetchByteArrayOp0 = 1300 -primOpTag PrefetchMutableByteArrayOp0 = 1301 -primOpTag PrefetchAddrOp0 = 1302 -primOpTag PrefetchValueOp0 = 1303 +maxPrimOpTag = 1311 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 0 +primOpTag CharGeOp = 1 +primOpTag CharEqOp = 2 +primOpTag CharNeOp = 3 +primOpTag CharLtOp = 4 +primOpTag CharLeOp = 5 +primOpTag OrdOp = 6 +primOpTag Int8ToIntOp = 7 +primOpTag IntToInt8Op = 8 +primOpTag Int8NegOp = 9 +primOpTag Int8AddOp = 10 +primOpTag Int8SubOp = 11 +primOpTag Int8MulOp = 12 +primOpTag Int8QuotOp = 13 +primOpTag Int8RemOp = 14 +primOpTag Int8QuotRemOp = 15 +primOpTag Int8SllOp = 16 +primOpTag Int8SraOp = 17 +primOpTag Int8SrlOp = 18 +primOpTag Int8ToWord8Op = 19 +primOpTag Int8EqOp = 20 +primOpTag Int8GeOp = 21 +primOpTag Int8GtOp = 22 +primOpTag Int8LeOp = 23 +primOpTag Int8LtOp = 24 +primOpTag Int8NeOp = 25 +primOpTag Word8ToWordOp = 26 +primOpTag WordToWord8Op = 27 +primOpTag Word8AddOp = 28 +primOpTag Word8SubOp = 29 +primOpTag Word8MulOp = 30 +primOpTag Word8QuotOp = 31 +primOpTag Word8RemOp = 32 +primOpTag Word8QuotRemOp = 33 +primOpTag Word8AndOp = 34 +primOpTag Word8OrOp = 35 +primOpTag Word8XorOp = 36 +primOpTag Word8NotOp = 37 +primOpTag Word8SllOp = 38 +primOpTag Word8SrlOp = 39 +primOpTag Word8ToInt8Op = 40 +primOpTag Word8EqOp = 41 +primOpTag Word8GeOp = 42 +primOpTag Word8GtOp = 43 +primOpTag Word8LeOp = 44 +primOpTag Word8LtOp = 45 +primOpTag Word8NeOp = 46 +primOpTag Int16ToIntOp = 47 +primOpTag IntToInt16Op = 48 +primOpTag Int16NegOp = 49 +primOpTag Int16AddOp = 50 +primOpTag Int16SubOp = 51 +primOpTag Int16MulOp = 52 +primOpTag Int16QuotOp = 53 +primOpTag Int16RemOp = 54 +primOpTag Int16QuotRemOp = 55 +primOpTag Int16SllOp = 56 +primOpTag Int16SraOp = 57 +primOpTag Int16SrlOp = 58 +primOpTag Int16ToWord16Op = 59 +primOpTag Int16EqOp = 60 +primOpTag Int16GeOp = 61 +primOpTag Int16GtOp = 62 +primOpTag Int16LeOp = 63 +primOpTag Int16LtOp = 64 +primOpTag Int16NeOp = 65 +primOpTag Word16ToWordOp = 66 +primOpTag WordToWord16Op = 67 +primOpTag Word16AddOp = 68 +primOpTag Word16SubOp = 69 +primOpTag Word16MulOp = 70 +primOpTag Word16QuotOp = 71 +primOpTag Word16RemOp = 72 +primOpTag Word16QuotRemOp = 73 +primOpTag Word16AndOp = 74 +primOpTag Word16OrOp = 75 +primOpTag Word16XorOp = 76 +primOpTag Word16NotOp = 77 +primOpTag Word16SllOp = 78 +primOpTag Word16SrlOp = 79 +primOpTag Word16ToInt16Op = 80 +primOpTag Word16EqOp = 81 +primOpTag Word16GeOp = 82 +primOpTag Word16GtOp = 83 +primOpTag Word16LeOp = 84 +primOpTag Word16LtOp = 85 +primOpTag Word16NeOp = 86 +primOpTag Int32ToIntOp = 87 +primOpTag IntToInt32Op = 88 +primOpTag Int32NegOp = 89 +primOpTag Int32AddOp = 90 +primOpTag Int32SubOp = 91 +primOpTag Int32MulOp = 92 +primOpTag Int32QuotOp = 93 +primOpTag Int32RemOp = 94 +primOpTag Int32QuotRemOp = 95 +primOpTag Int32SllOp = 96 +primOpTag Int32SraOp = 97 +primOpTag Int32SrlOp = 98 +primOpTag Int32ToWord32Op = 99 +primOpTag Int32EqOp = 100 +primOpTag Int32GeOp = 101 +primOpTag Int32GtOp = 102 +primOpTag Int32LeOp = 103 +primOpTag Int32LtOp = 104 +primOpTag Int32NeOp = 105 +primOpTag Word32ToWordOp = 106 +primOpTag WordToWord32Op = 107 +primOpTag Word32AddOp = 108 +primOpTag Word32SubOp = 109 +primOpTag Word32MulOp = 110 +primOpTag Word32QuotOp = 111 +primOpTag Word32RemOp = 112 +primOpTag Word32QuotRemOp = 113 +primOpTag Word32AndOp = 114 +primOpTag Word32OrOp = 115 +primOpTag Word32XorOp = 116 +primOpTag Word32NotOp = 117 +primOpTag Word32SllOp = 118 +primOpTag Word32SrlOp = 119 +primOpTag Word32ToInt32Op = 120 +primOpTag Word32EqOp = 121 +primOpTag Word32GeOp = 122 +primOpTag Word32GtOp = 123 +primOpTag Word32LeOp = 124 +primOpTag Word32LtOp = 125 +primOpTag Word32NeOp = 126 +primOpTag Int64ToIntOp = 127 +primOpTag IntToInt64Op = 128 +primOpTag Int64NegOp = 129 +primOpTag Int64AddOp = 130 +primOpTag Int64SubOp = 131 +primOpTag Int64MulOp = 132 +primOpTag Int64QuotOp = 133 +primOpTag Int64RemOp = 134 +primOpTag Int64SllOp = 135 +primOpTag Int64SraOp = 136 +primOpTag Int64SrlOp = 137 +primOpTag Int64ToWord64Op = 138 +primOpTag Int64EqOp = 139 +primOpTag Int64GeOp = 140 +primOpTag Int64GtOp = 141 +primOpTag Int64LeOp = 142 +primOpTag Int64LtOp = 143 +primOpTag Int64NeOp = 144 +primOpTag Word64ToWordOp = 145 +primOpTag WordToWord64Op = 146 +primOpTag Word64AddOp = 147 +primOpTag Word64SubOp = 148 +primOpTag Word64MulOp = 149 +primOpTag Word64QuotOp = 150 +primOpTag Word64RemOp = 151 +primOpTag Word64AndOp = 152 +primOpTag Word64OrOp = 153 +primOpTag Word64XorOp = 154 +primOpTag Word64NotOp = 155 +primOpTag Word64SllOp = 156 +primOpTag Word64SrlOp = 157 +primOpTag Word64ToInt64Op = 158 +primOpTag Word64EqOp = 159 +primOpTag Word64GeOp = 160 +primOpTag Word64GtOp = 161 +primOpTag Word64LeOp = 162 +primOpTag Word64LtOp = 163 +primOpTag Word64NeOp = 164 +primOpTag IntAddOp = 165 +primOpTag IntSubOp = 166 +primOpTag IntMulOp = 167 +primOpTag IntMul2Op = 168 +primOpTag IntMulMayOfloOp = 169 +primOpTag IntQuotOp = 170 +primOpTag IntRemOp = 171 +primOpTag IntQuotRemOp = 172 +primOpTag IntAndOp = 173 +primOpTag IntOrOp = 174 +primOpTag IntXorOp = 175 +primOpTag IntNotOp = 176 +primOpTag IntNegOp = 177 +primOpTag IntAddCOp = 178 +primOpTag IntSubCOp = 179 +primOpTag IntGtOp = 180 +primOpTag IntGeOp = 181 +primOpTag IntEqOp = 182 +primOpTag IntNeOp = 183 +primOpTag IntLtOp = 184 +primOpTag IntLeOp = 185 +primOpTag ChrOp = 186 +primOpTag IntToWordOp = 187 +primOpTag IntToFloatOp = 188 +primOpTag IntToDoubleOp = 189 +primOpTag WordToFloatOp = 190 +primOpTag WordToDoubleOp = 191 +primOpTag IntSllOp = 192 +primOpTag IntSraOp = 193 +primOpTag IntSrlOp = 194 +primOpTag WordAddOp = 195 +primOpTag WordAddCOp = 196 +primOpTag WordSubCOp = 197 +primOpTag WordAdd2Op = 198 +primOpTag WordSubOp = 199 +primOpTag WordMulOp = 200 +primOpTag WordMul2Op = 201 +primOpTag WordQuotOp = 202 +primOpTag WordRemOp = 203 +primOpTag WordQuotRemOp = 204 +primOpTag WordQuotRem2Op = 205 +primOpTag WordAndOp = 206 +primOpTag WordOrOp = 207 +primOpTag WordXorOp = 208 +primOpTag WordNotOp = 209 +primOpTag WordSllOp = 210 +primOpTag WordSrlOp = 211 +primOpTag WordToIntOp = 212 +primOpTag WordGtOp = 213 +primOpTag WordGeOp = 214 +primOpTag WordEqOp = 215 +primOpTag WordNeOp = 216 +primOpTag WordLtOp = 217 +primOpTag WordLeOp = 218 +primOpTag PopCnt8Op = 219 +primOpTag PopCnt16Op = 220 +primOpTag PopCnt32Op = 221 +primOpTag PopCnt64Op = 222 +primOpTag PopCntOp = 223 +primOpTag Pdep8Op = 224 +primOpTag Pdep16Op = 225 +primOpTag Pdep32Op = 226 +primOpTag Pdep64Op = 227 +primOpTag PdepOp = 228 +primOpTag Pext8Op = 229 +primOpTag Pext16Op = 230 +primOpTag Pext32Op = 231 +primOpTag Pext64Op = 232 +primOpTag PextOp = 233 +primOpTag Clz8Op = 234 +primOpTag Clz16Op = 235 +primOpTag Clz32Op = 236 +primOpTag Clz64Op = 237 +primOpTag ClzOp = 238 +primOpTag Ctz8Op = 239 +primOpTag Ctz16Op = 240 +primOpTag Ctz32Op = 241 +primOpTag Ctz64Op = 242 +primOpTag CtzOp = 243 +primOpTag BSwap16Op = 244 +primOpTag BSwap32Op = 245 +primOpTag BSwap64Op = 246 +primOpTag BSwapOp = 247 +primOpTag BRev8Op = 248 +primOpTag BRev16Op = 249 +primOpTag BRev32Op = 250 +primOpTag BRev64Op = 251 +primOpTag BRevOp = 252 +primOpTag Narrow8IntOp = 253 +primOpTag Narrow16IntOp = 254 +primOpTag Narrow32IntOp = 255 +primOpTag Narrow8WordOp = 256 +primOpTag Narrow16WordOp = 257 +primOpTag Narrow32WordOp = 258 +primOpTag DoubleGtOp = 259 +primOpTag DoubleGeOp = 260 +primOpTag DoubleEqOp = 261 +primOpTag DoubleNeOp = 262 +primOpTag DoubleLtOp = 263 +primOpTag DoubleLeOp = 264 +primOpTag DoubleAddOp = 265 +primOpTag DoubleSubOp = 266 +primOpTag DoubleMulOp = 267 +primOpTag DoubleDivOp = 268 +primOpTag DoubleNegOp = 269 +primOpTag DoubleFabsOp = 270 +primOpTag DoubleToIntOp = 271 +primOpTag DoubleToFloatOp = 272 +primOpTag DoubleExpOp = 273 +primOpTag DoubleExpM1Op = 274 +primOpTag DoubleLogOp = 275 +primOpTag DoubleLog1POp = 276 +primOpTag DoubleSqrtOp = 277 +primOpTag DoubleSinOp = 278 +primOpTag DoubleCosOp = 279 +primOpTag DoubleTanOp = 280 +primOpTag DoubleAsinOp = 281 +primOpTag DoubleAcosOp = 282 +primOpTag DoubleAtanOp = 283 +primOpTag DoubleSinhOp = 284 +primOpTag DoubleCoshOp = 285 +primOpTag DoubleTanhOp = 286 +primOpTag DoubleAsinhOp = 287 +primOpTag DoubleAcoshOp = 288 +primOpTag DoubleAtanhOp = 289 +primOpTag DoublePowerOp = 290 +primOpTag DoubleDecode_2IntOp = 291 +primOpTag DoubleDecode_Int64Op = 292 +primOpTag FloatGtOp = 293 +primOpTag FloatGeOp = 294 +primOpTag FloatEqOp = 295 +primOpTag FloatNeOp = 296 +primOpTag FloatLtOp = 297 +primOpTag FloatLeOp = 298 +primOpTag FloatAddOp = 299 +primOpTag FloatSubOp = 300 +primOpTag FloatMulOp = 301 +primOpTag FloatDivOp = 302 +primOpTag FloatNegOp = 303 +primOpTag FloatFabsOp = 304 +primOpTag FloatToIntOp = 305 +primOpTag FloatExpOp = 306 +primOpTag FloatExpM1Op = 307 +primOpTag FloatLogOp = 308 +primOpTag FloatLog1POp = 309 +primOpTag FloatSqrtOp = 310 +primOpTag FloatSinOp = 311 +primOpTag FloatCosOp = 312 +primOpTag FloatTanOp = 313 +primOpTag FloatAsinOp = 314 +primOpTag FloatAcosOp = 315 +primOpTag FloatAtanOp = 316 +primOpTag FloatSinhOp = 317 +primOpTag FloatCoshOp = 318 +primOpTag FloatTanhOp = 319 +primOpTag FloatAsinhOp = 320 +primOpTag FloatAcoshOp = 321 +primOpTag FloatAtanhOp = 322 +primOpTag FloatPowerOp = 323 +primOpTag FloatToDoubleOp = 324 +primOpTag FloatDecode_IntOp = 325 +primOpTag NewArrayOp = 326 +primOpTag ReadArrayOp = 327 +primOpTag WriteArrayOp = 328 +primOpTag SizeofArrayOp = 329 +primOpTag SizeofMutableArrayOp = 330 +primOpTag IndexArrayOp = 331 +primOpTag UnsafeFreezeArrayOp = 332 +primOpTag UnsafeThawArrayOp = 333 +primOpTag CopyArrayOp = 334 +primOpTag CopyMutableArrayOp = 335 +primOpTag CloneArrayOp = 336 +primOpTag CloneMutableArrayOp = 337 +primOpTag FreezeArrayOp = 338 +primOpTag ThawArrayOp = 339 +primOpTag CasArrayOp = 340 +primOpTag NewSmallArrayOp = 341 +primOpTag ShrinkSmallMutableArrayOp_Char = 342 +primOpTag ReadSmallArrayOp = 343 +primOpTag WriteSmallArrayOp = 344 +primOpTag SizeofSmallArrayOp = 345 +primOpTag SizeofSmallMutableArrayOp = 346 +primOpTag GetSizeofSmallMutableArrayOp = 347 +primOpTag IndexSmallArrayOp = 348 +primOpTag UnsafeFreezeSmallArrayOp = 349 +primOpTag UnsafeThawSmallArrayOp = 350 +primOpTag CopySmallArrayOp = 351 +primOpTag CopySmallMutableArrayOp = 352 +primOpTag CloneSmallArrayOp = 353 +primOpTag CloneSmallMutableArrayOp = 354 +primOpTag FreezeSmallArrayOp = 355 +primOpTag ThawSmallArrayOp = 356 +primOpTag CasSmallArrayOp = 357 +primOpTag NewByteArrayOp_Char = 358 +primOpTag NewPinnedByteArrayOp_Char = 359 +primOpTag NewAlignedPinnedByteArrayOp_Char = 360 +primOpTag MutableByteArrayIsPinnedOp = 361 +primOpTag ByteArrayIsPinnedOp = 362 +primOpTag ByteArrayContents_Char = 363 +primOpTag MutableByteArrayContents_Char = 364 +primOpTag ShrinkMutableByteArrayOp_Char = 365 +primOpTag ResizeMutableByteArrayOp_Char = 366 +primOpTag UnsafeFreezeByteArrayOp = 367 +primOpTag SizeofByteArrayOp = 368 +primOpTag SizeofMutableByteArrayOp = 369 +primOpTag GetSizeofMutableByteArrayOp = 370 +primOpTag IndexByteArrayOp_Char = 371 +primOpTag IndexByteArrayOp_WideChar = 372 +primOpTag IndexByteArrayOp_Int = 373 +primOpTag IndexByteArrayOp_Word = 374 +primOpTag IndexByteArrayOp_Addr = 375 +primOpTag IndexByteArrayOp_Float = 376 +primOpTag IndexByteArrayOp_Double = 377 +primOpTag IndexByteArrayOp_StablePtr = 378 +primOpTag IndexByteArrayOp_Int8 = 379 +primOpTag IndexByteArrayOp_Int16 = 380 +primOpTag IndexByteArrayOp_Int32 = 381 +primOpTag IndexByteArrayOp_Int64 = 382 +primOpTag IndexByteArrayOp_Word8 = 383 +primOpTag IndexByteArrayOp_Word16 = 384 +primOpTag IndexByteArrayOp_Word32 = 385 +primOpTag IndexByteArrayOp_Word64 = 386 +primOpTag IndexByteArrayOp_Word8AsChar = 387 +primOpTag IndexByteArrayOp_Word8AsWideChar = 388 +primOpTag IndexByteArrayOp_Word8AsInt = 389 +primOpTag IndexByteArrayOp_Word8AsWord = 390 +primOpTag IndexByteArrayOp_Word8AsAddr = 391 +primOpTag IndexByteArrayOp_Word8AsFloat = 392 +primOpTag IndexByteArrayOp_Word8AsDouble = 393 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 394 +primOpTag IndexByteArrayOp_Word8AsInt16 = 395 +primOpTag IndexByteArrayOp_Word8AsInt32 = 396 +primOpTag IndexByteArrayOp_Word8AsInt64 = 397 +primOpTag IndexByteArrayOp_Word8AsWord16 = 398 +primOpTag IndexByteArrayOp_Word8AsWord32 = 399 +primOpTag IndexByteArrayOp_Word8AsWord64 = 400 +primOpTag ReadByteArrayOp_Char = 401 +primOpTag ReadByteArrayOp_WideChar = 402 +primOpTag ReadByteArrayOp_Int = 403 +primOpTag ReadByteArrayOp_Word = 404 +primOpTag ReadByteArrayOp_Addr = 405 +primOpTag ReadByteArrayOp_Float = 406 +primOpTag ReadByteArrayOp_Double = 407 +primOpTag ReadByteArrayOp_StablePtr = 408 +primOpTag ReadByteArrayOp_Int8 = 409 +primOpTag ReadByteArrayOp_Int16 = 410 +primOpTag ReadByteArrayOp_Int32 = 411 +primOpTag ReadByteArrayOp_Int64 = 412 +primOpTag ReadByteArrayOp_Word8 = 413 +primOpTag ReadByteArrayOp_Word16 = 414 +primOpTag ReadByteArrayOp_Word32 = 415 +primOpTag ReadByteArrayOp_Word64 = 416 +primOpTag ReadByteArrayOp_Word8AsChar = 417 +primOpTag ReadByteArrayOp_Word8AsWideChar = 418 +primOpTag ReadByteArrayOp_Word8AsInt = 419 +primOpTag ReadByteArrayOp_Word8AsWord = 420 +primOpTag ReadByteArrayOp_Word8AsAddr = 421 +primOpTag ReadByteArrayOp_Word8AsFloat = 422 +primOpTag ReadByteArrayOp_Word8AsDouble = 423 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 424 +primOpTag ReadByteArrayOp_Word8AsInt16 = 425 +primOpTag ReadByteArrayOp_Word8AsInt32 = 426 +primOpTag ReadByteArrayOp_Word8AsInt64 = 427 +primOpTag ReadByteArrayOp_Word8AsWord16 = 428 +primOpTag ReadByteArrayOp_Word8AsWord32 = 429 +primOpTag ReadByteArrayOp_Word8AsWord64 = 430 +primOpTag WriteByteArrayOp_Char = 431 +primOpTag WriteByteArrayOp_WideChar = 432 +primOpTag WriteByteArrayOp_Int = 433 +primOpTag WriteByteArrayOp_Word = 434 +primOpTag WriteByteArrayOp_Addr = 435 +primOpTag WriteByteArrayOp_Float = 436 +primOpTag WriteByteArrayOp_Double = 437 +primOpTag WriteByteArrayOp_StablePtr = 438 +primOpTag WriteByteArrayOp_Int8 = 439 +primOpTag WriteByteArrayOp_Int16 = 440 +primOpTag WriteByteArrayOp_Int32 = 441 +primOpTag WriteByteArrayOp_Int64 = 442 +primOpTag WriteByteArrayOp_Word8 = 443 +primOpTag WriteByteArrayOp_Word16 = 444 +primOpTag WriteByteArrayOp_Word32 = 445 +primOpTag WriteByteArrayOp_Word64 = 446 +primOpTag WriteByteArrayOp_Word8AsChar = 447 +primOpTag WriteByteArrayOp_Word8AsWideChar = 448 +primOpTag WriteByteArrayOp_Word8AsInt = 449 +primOpTag WriteByteArrayOp_Word8AsWord = 450 +primOpTag WriteByteArrayOp_Word8AsAddr = 451 +primOpTag WriteByteArrayOp_Word8AsFloat = 452 +primOpTag WriteByteArrayOp_Word8AsDouble = 453 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 454 +primOpTag WriteByteArrayOp_Word8AsInt16 = 455 +primOpTag WriteByteArrayOp_Word8AsInt32 = 456 +primOpTag WriteByteArrayOp_Word8AsInt64 = 457 +primOpTag WriteByteArrayOp_Word8AsWord16 = 458 +primOpTag WriteByteArrayOp_Word8AsWord32 = 459 +primOpTag WriteByteArrayOp_Word8AsWord64 = 460 +primOpTag CompareByteArraysOp = 461 +primOpTag CopyByteArrayOp = 462 +primOpTag CopyMutableByteArrayOp = 463 +primOpTag CopyByteArrayToAddrOp = 464 +primOpTag CopyMutableByteArrayToAddrOp = 465 +primOpTag CopyAddrToByteArrayOp = 466 +primOpTag SetByteArrayOp = 467 +primOpTag AtomicReadByteArrayOp_Int = 468 +primOpTag AtomicWriteByteArrayOp_Int = 469 +primOpTag CasByteArrayOp_Int = 470 +primOpTag CasByteArrayOp_Int8 = 471 +primOpTag CasByteArrayOp_Int16 = 472 +primOpTag CasByteArrayOp_Int32 = 473 +primOpTag CasByteArrayOp_Int64 = 474 +primOpTag FetchAddByteArrayOp_Int = 475 +primOpTag FetchSubByteArrayOp_Int = 476 +primOpTag FetchAndByteArrayOp_Int = 477 +primOpTag FetchNandByteArrayOp_Int = 478 +primOpTag FetchOrByteArrayOp_Int = 479 +primOpTag FetchXorByteArrayOp_Int = 480 +primOpTag AddrAddOp = 481 +primOpTag AddrSubOp = 482 +primOpTag AddrRemOp = 483 +primOpTag AddrToIntOp = 484 +primOpTag IntToAddrOp = 485 +primOpTag AddrGtOp = 486 +primOpTag AddrGeOp = 487 +primOpTag AddrEqOp = 488 +primOpTag AddrNeOp = 489 +primOpTag AddrLtOp = 490 +primOpTag AddrLeOp = 491 +primOpTag IndexOffAddrOp_Char = 492 +primOpTag IndexOffAddrOp_WideChar = 493 +primOpTag IndexOffAddrOp_Int = 494 +primOpTag IndexOffAddrOp_Word = 495 +primOpTag IndexOffAddrOp_Addr = 496 +primOpTag IndexOffAddrOp_Float = 497 +primOpTag IndexOffAddrOp_Double = 498 +primOpTag IndexOffAddrOp_StablePtr = 499 +primOpTag IndexOffAddrOp_Int8 = 500 +primOpTag IndexOffAddrOp_Int16 = 501 +primOpTag IndexOffAddrOp_Int32 = 502 +primOpTag IndexOffAddrOp_Int64 = 503 +primOpTag IndexOffAddrOp_Word8 = 504 +primOpTag IndexOffAddrOp_Word16 = 505 +primOpTag IndexOffAddrOp_Word32 = 506 +primOpTag IndexOffAddrOp_Word64 = 507 +primOpTag ReadOffAddrOp_Char = 508 +primOpTag ReadOffAddrOp_WideChar = 509 +primOpTag ReadOffAddrOp_Int = 510 +primOpTag ReadOffAddrOp_Word = 511 +primOpTag ReadOffAddrOp_Addr = 512 +primOpTag ReadOffAddrOp_Float = 513 +primOpTag ReadOffAddrOp_Double = 514 +primOpTag ReadOffAddrOp_StablePtr = 515 +primOpTag ReadOffAddrOp_Int8 = 516 +primOpTag ReadOffAddrOp_Int16 = 517 +primOpTag ReadOffAddrOp_Int32 = 518 +primOpTag ReadOffAddrOp_Int64 = 519 +primOpTag ReadOffAddrOp_Word8 = 520 +primOpTag ReadOffAddrOp_Word16 = 521 +primOpTag ReadOffAddrOp_Word32 = 522 +primOpTag ReadOffAddrOp_Word64 = 523 +primOpTag WriteOffAddrOp_Char = 524 +primOpTag WriteOffAddrOp_WideChar = 525 +primOpTag WriteOffAddrOp_Int = 526 +primOpTag WriteOffAddrOp_Word = 527 +primOpTag WriteOffAddrOp_Addr = 528 +primOpTag WriteOffAddrOp_Float = 529 +primOpTag WriteOffAddrOp_Double = 530 +primOpTag WriteOffAddrOp_StablePtr = 531 +primOpTag WriteOffAddrOp_Int8 = 532 +primOpTag WriteOffAddrOp_Int16 = 533 +primOpTag WriteOffAddrOp_Int32 = 534 +primOpTag WriteOffAddrOp_Int64 = 535 +primOpTag WriteOffAddrOp_Word8 = 536 +primOpTag WriteOffAddrOp_Word16 = 537 +primOpTag WriteOffAddrOp_Word32 = 538 +primOpTag WriteOffAddrOp_Word64 = 539 +primOpTag InterlockedExchange_Addr = 540 +primOpTag InterlockedExchange_Word = 541 +primOpTag CasAddrOp_Addr = 542 +primOpTag CasAddrOp_Word = 543 +primOpTag CasAddrOp_Word8 = 544 +primOpTag CasAddrOp_Word16 = 545 +primOpTag CasAddrOp_Word32 = 546 +primOpTag CasAddrOp_Word64 = 547 +primOpTag FetchAddAddrOp_Word = 548 +primOpTag FetchSubAddrOp_Word = 549 +primOpTag FetchAndAddrOp_Word = 550 +primOpTag FetchNandAddrOp_Word = 551 +primOpTag FetchOrAddrOp_Word = 552 +primOpTag FetchXorAddrOp_Word = 553 +primOpTag AtomicReadAddrOp_Word = 554 +primOpTag AtomicWriteAddrOp_Word = 555 +primOpTag NewMutVarOp = 556 +primOpTag ReadMutVarOp = 557 +primOpTag WriteMutVarOp = 558 +primOpTag AtomicModifyMutVar2Op = 559 +primOpTag AtomicModifyMutVar_Op = 560 +primOpTag CasMutVarOp = 561 +primOpTag CatchOp = 562 +primOpTag RaiseOp = 563 +primOpTag RaiseUnderflowOp = 564 +primOpTag RaiseOverflowOp = 565 +primOpTag RaiseDivZeroOp = 566 +primOpTag RaiseIOOp = 567 +primOpTag MaskAsyncExceptionsOp = 568 +primOpTag MaskUninterruptibleOp = 569 +primOpTag UnmaskAsyncExceptionsOp = 570 +primOpTag MaskStatus = 571 +primOpTag NewPromptTagOp = 572 +primOpTag PromptOp = 573 +primOpTag Control0Op = 574 +primOpTag AtomicallyOp = 575 +primOpTag RetryOp = 576 +primOpTag CatchRetryOp = 577 +primOpTag CatchSTMOp = 578 +primOpTag NewTVarOp = 579 +primOpTag ReadTVarOp = 580 +primOpTag ReadTVarIOOp = 581 +primOpTag WriteTVarOp = 582 +primOpTag NewMVarOp = 583 +primOpTag TakeMVarOp = 584 +primOpTag TryTakeMVarOp = 585 +primOpTag PutMVarOp = 586 +primOpTag TryPutMVarOp = 587 +primOpTag ReadMVarOp = 588 +primOpTag TryReadMVarOp = 589 +primOpTag IsEmptyMVarOp = 590 +primOpTag NewIOPortOp = 591 +primOpTag ReadIOPortOp = 592 +primOpTag WriteIOPortOp = 593 +primOpTag DelayOp = 594 +primOpTag WaitReadOp = 595 +primOpTag WaitWriteOp = 596 +primOpTag ForkOp = 597 +primOpTag ForkOnOp = 598 +primOpTag KillThreadOp = 599 +primOpTag YieldOp = 600 +primOpTag MyThreadIdOp = 601 +primOpTag LabelThreadOp = 602 +primOpTag IsCurrentThreadBoundOp = 603 +primOpTag NoDuplicateOp = 604 +primOpTag GetThreadLabelOp = 605 +primOpTag ThreadStatusOp = 606 +primOpTag ListThreadsOp = 607 +primOpTag MkWeakOp = 608 +primOpTag MkWeakNoFinalizerOp = 609 +primOpTag AddCFinalizerToWeakOp = 610 +primOpTag DeRefWeakOp = 611 +primOpTag FinalizeWeakOp = 612 +primOpTag TouchOp = 613 +primOpTag MakeStablePtrOp = 614 +primOpTag DeRefStablePtrOp = 615 +primOpTag EqStablePtrOp = 616 +primOpTag MakeStableNameOp = 617 +primOpTag StableNameToIntOp = 618 +primOpTag CompactNewOp = 619 +primOpTag CompactResizeOp = 620 +primOpTag CompactContainsOp = 621 +primOpTag CompactContainsAnyOp = 622 +primOpTag CompactGetFirstBlockOp = 623 +primOpTag CompactGetNextBlockOp = 624 +primOpTag CompactAllocateBlockOp = 625 +primOpTag CompactFixupPointersOp = 626 +primOpTag CompactAdd = 627 +primOpTag CompactAddWithSharing = 628 +primOpTag CompactSize = 629 +primOpTag ReallyUnsafePtrEqualityOp = 630 +primOpTag ParOp = 631 +primOpTag SparkOp = 632 +primOpTag SeqOp = 633 +primOpTag GetSparkOp = 634 +primOpTag NumSparks = 635 +primOpTag KeepAliveOp = 636 +primOpTag DataToTagOp = 637 +primOpTag TagToEnumOp = 638 +primOpTag AddrToAnyOp = 639 +primOpTag AnyToAddrOp = 640 +primOpTag MkApUpd0_Op = 641 +primOpTag NewBCOOp = 642 +primOpTag UnpackClosureOp = 643 +primOpTag ClosureSizeOp = 644 +primOpTag GetApStackValOp = 645 +primOpTag GetCCSOfOp = 646 +primOpTag GetCurrentCCSOp = 647 +primOpTag ClearCCSOp = 648 +primOpTag WhereFromOp = 649 +primOpTag TraceEventOp = 650 +primOpTag TraceEventBinaryOp = 651 +primOpTag TraceMarkerOp = 652 +primOpTag SetThreadAllocationCounter = 653 +primOpTag (VecBroadcastOp IntVec 16 W8) = 654 +primOpTag (VecBroadcastOp IntVec 8 W16) = 655 +primOpTag (VecBroadcastOp IntVec 4 W32) = 656 +primOpTag (VecBroadcastOp IntVec 2 W64) = 657 +primOpTag (VecBroadcastOp IntVec 32 W8) = 658 +primOpTag (VecBroadcastOp IntVec 16 W16) = 659 +primOpTag (VecBroadcastOp IntVec 8 W32) = 660 +primOpTag (VecBroadcastOp IntVec 4 W64) = 661 +primOpTag (VecBroadcastOp IntVec 64 W8) = 662 +primOpTag (VecBroadcastOp IntVec 32 W16) = 663 +primOpTag (VecBroadcastOp IntVec 16 W32) = 664 +primOpTag (VecBroadcastOp IntVec 8 W64) = 665 +primOpTag (VecBroadcastOp WordVec 16 W8) = 666 +primOpTag (VecBroadcastOp WordVec 8 W16) = 667 +primOpTag (VecBroadcastOp WordVec 4 W32) = 668 +primOpTag (VecBroadcastOp WordVec 2 W64) = 669 +primOpTag (VecBroadcastOp WordVec 32 W8) = 670 +primOpTag (VecBroadcastOp WordVec 16 W16) = 671 +primOpTag (VecBroadcastOp WordVec 8 W32) = 672 +primOpTag (VecBroadcastOp WordVec 4 W64) = 673 +primOpTag (VecBroadcastOp WordVec 64 W8) = 674 +primOpTag (VecBroadcastOp WordVec 32 W16) = 675 +primOpTag (VecBroadcastOp WordVec 16 W32) = 676 +primOpTag (VecBroadcastOp WordVec 8 W64) = 677 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 678 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 679 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 680 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 681 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 682 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 683 +primOpTag (VecPackOp IntVec 16 W8) = 684 +primOpTag (VecPackOp IntVec 8 W16) = 685 +primOpTag (VecPackOp IntVec 4 W32) = 686 +primOpTag (VecPackOp IntVec 2 W64) = 687 +primOpTag (VecPackOp IntVec 32 W8) = 688 +primOpTag (VecPackOp IntVec 16 W16) = 689 +primOpTag (VecPackOp IntVec 8 W32) = 690 +primOpTag (VecPackOp IntVec 4 W64) = 691 +primOpTag (VecPackOp IntVec 64 W8) = 692 +primOpTag (VecPackOp IntVec 32 W16) = 693 +primOpTag (VecPackOp IntVec 16 W32) = 694 +primOpTag (VecPackOp IntVec 8 W64) = 695 +primOpTag (VecPackOp WordVec 16 W8) = 696 +primOpTag (VecPackOp WordVec 8 W16) = 697 +primOpTag (VecPackOp WordVec 4 W32) = 698 +primOpTag (VecPackOp WordVec 2 W64) = 699 +primOpTag (VecPackOp WordVec 32 W8) = 700 +primOpTag (VecPackOp WordVec 16 W16) = 701 +primOpTag (VecPackOp WordVec 8 W32) = 702 +primOpTag (VecPackOp WordVec 4 W64) = 703 +primOpTag (VecPackOp WordVec 64 W8) = 704 +primOpTag (VecPackOp WordVec 32 W16) = 705 +primOpTag (VecPackOp WordVec 16 W32) = 706 +primOpTag (VecPackOp WordVec 8 W64) = 707 +primOpTag (VecPackOp FloatVec 4 W32) = 708 +primOpTag (VecPackOp FloatVec 2 W64) = 709 +primOpTag (VecPackOp FloatVec 8 W32) = 710 +primOpTag (VecPackOp FloatVec 4 W64) = 711 +primOpTag (VecPackOp FloatVec 16 W32) = 712 +primOpTag (VecPackOp FloatVec 8 W64) = 713 +primOpTag (VecUnpackOp IntVec 16 W8) = 714 +primOpTag (VecUnpackOp IntVec 8 W16) = 715 +primOpTag (VecUnpackOp IntVec 4 W32) = 716 +primOpTag (VecUnpackOp IntVec 2 W64) = 717 +primOpTag (VecUnpackOp IntVec 32 W8) = 718 +primOpTag (VecUnpackOp IntVec 16 W16) = 719 +primOpTag (VecUnpackOp IntVec 8 W32) = 720 +primOpTag (VecUnpackOp IntVec 4 W64) = 721 +primOpTag (VecUnpackOp IntVec 64 W8) = 722 +primOpTag (VecUnpackOp IntVec 32 W16) = 723 +primOpTag (VecUnpackOp IntVec 16 W32) = 724 +primOpTag (VecUnpackOp IntVec 8 W64) = 725 +primOpTag (VecUnpackOp WordVec 16 W8) = 726 +primOpTag (VecUnpackOp WordVec 8 W16) = 727 +primOpTag (VecUnpackOp WordVec 4 W32) = 728 +primOpTag (VecUnpackOp WordVec 2 W64) = 729 +primOpTag (VecUnpackOp WordVec 32 W8) = 730 +primOpTag (VecUnpackOp WordVec 16 W16) = 731 +primOpTag (VecUnpackOp WordVec 8 W32) = 732 +primOpTag (VecUnpackOp WordVec 4 W64) = 733 +primOpTag (VecUnpackOp WordVec 64 W8) = 734 +primOpTag (VecUnpackOp WordVec 32 W16) = 735 +primOpTag (VecUnpackOp WordVec 16 W32) = 736 +primOpTag (VecUnpackOp WordVec 8 W64) = 737 +primOpTag (VecUnpackOp FloatVec 4 W32) = 738 +primOpTag (VecUnpackOp FloatVec 2 W64) = 739 +primOpTag (VecUnpackOp FloatVec 8 W32) = 740 +primOpTag (VecUnpackOp FloatVec 4 W64) = 741 +primOpTag (VecUnpackOp FloatVec 16 W32) = 742 +primOpTag (VecUnpackOp FloatVec 8 W64) = 743 +primOpTag (VecInsertOp IntVec 16 W8) = 744 +primOpTag (VecInsertOp IntVec 8 W16) = 745 +primOpTag (VecInsertOp IntVec 4 W32) = 746 +primOpTag (VecInsertOp IntVec 2 W64) = 747 +primOpTag (VecInsertOp IntVec 32 W8) = 748 +primOpTag (VecInsertOp IntVec 16 W16) = 749 +primOpTag (VecInsertOp IntVec 8 W32) = 750 +primOpTag (VecInsertOp IntVec 4 W64) = 751 +primOpTag (VecInsertOp IntVec 64 W8) = 752 +primOpTag (VecInsertOp IntVec 32 W16) = 753 +primOpTag (VecInsertOp IntVec 16 W32) = 754 +primOpTag (VecInsertOp IntVec 8 W64) = 755 +primOpTag (VecInsertOp WordVec 16 W8) = 756 +primOpTag (VecInsertOp WordVec 8 W16) = 757 +primOpTag (VecInsertOp WordVec 4 W32) = 758 +primOpTag (VecInsertOp WordVec 2 W64) = 759 +primOpTag (VecInsertOp WordVec 32 W8) = 760 +primOpTag (VecInsertOp WordVec 16 W16) = 761 +primOpTag (VecInsertOp WordVec 8 W32) = 762 +primOpTag (VecInsertOp WordVec 4 W64) = 763 +primOpTag (VecInsertOp WordVec 64 W8) = 764 +primOpTag (VecInsertOp WordVec 32 W16) = 765 +primOpTag (VecInsertOp WordVec 16 W32) = 766 +primOpTag (VecInsertOp WordVec 8 W64) = 767 +primOpTag (VecInsertOp FloatVec 4 W32) = 768 +primOpTag (VecInsertOp FloatVec 2 W64) = 769 +primOpTag (VecInsertOp FloatVec 8 W32) = 770 +primOpTag (VecInsertOp FloatVec 4 W64) = 771 +primOpTag (VecInsertOp FloatVec 16 W32) = 772 +primOpTag (VecInsertOp FloatVec 8 W64) = 773 +primOpTag (VecAddOp IntVec 16 W8) = 774 +primOpTag (VecAddOp IntVec 8 W16) = 775 +primOpTag (VecAddOp IntVec 4 W32) = 776 +primOpTag (VecAddOp IntVec 2 W64) = 777 +primOpTag (VecAddOp IntVec 32 W8) = 778 +primOpTag (VecAddOp IntVec 16 W16) = 779 +primOpTag (VecAddOp IntVec 8 W32) = 780 +primOpTag (VecAddOp IntVec 4 W64) = 781 +primOpTag (VecAddOp IntVec 64 W8) = 782 +primOpTag (VecAddOp IntVec 32 W16) = 783 +primOpTag (VecAddOp IntVec 16 W32) = 784 +primOpTag (VecAddOp IntVec 8 W64) = 785 +primOpTag (VecAddOp WordVec 16 W8) = 786 +primOpTag (VecAddOp WordVec 8 W16) = 787 +primOpTag (VecAddOp WordVec 4 W32) = 788 +primOpTag (VecAddOp WordVec 2 W64) = 789 +primOpTag (VecAddOp WordVec 32 W8) = 790 +primOpTag (VecAddOp WordVec 16 W16) = 791 +primOpTag (VecAddOp WordVec 8 W32) = 792 +primOpTag (VecAddOp WordVec 4 W64) = 793 +primOpTag (VecAddOp WordVec 64 W8) = 794 +primOpTag (VecAddOp WordVec 32 W16) = 795 +primOpTag (VecAddOp WordVec 16 W32) = 796 +primOpTag (VecAddOp WordVec 8 W64) = 797 +primOpTag (VecAddOp FloatVec 4 W32) = 798 +primOpTag (VecAddOp FloatVec 2 W64) = 799 +primOpTag (VecAddOp FloatVec 8 W32) = 800 +primOpTag (VecAddOp FloatVec 4 W64) = 801 +primOpTag (VecAddOp FloatVec 16 W32) = 802 +primOpTag (VecAddOp FloatVec 8 W64) = 803 +primOpTag (VecSubOp IntVec 16 W8) = 804 +primOpTag (VecSubOp IntVec 8 W16) = 805 +primOpTag (VecSubOp IntVec 4 W32) = 806 +primOpTag (VecSubOp IntVec 2 W64) = 807 +primOpTag (VecSubOp IntVec 32 W8) = 808 +primOpTag (VecSubOp IntVec 16 W16) = 809 +primOpTag (VecSubOp IntVec 8 W32) = 810 +primOpTag (VecSubOp IntVec 4 W64) = 811 +primOpTag (VecSubOp IntVec 64 W8) = 812 +primOpTag (VecSubOp IntVec 32 W16) = 813 +primOpTag (VecSubOp IntVec 16 W32) = 814 +primOpTag (VecSubOp IntVec 8 W64) = 815 +primOpTag (VecSubOp WordVec 16 W8) = 816 +primOpTag (VecSubOp WordVec 8 W16) = 817 +primOpTag (VecSubOp WordVec 4 W32) = 818 +primOpTag (VecSubOp WordVec 2 W64) = 819 +primOpTag (VecSubOp WordVec 32 W8) = 820 +primOpTag (VecSubOp WordVec 16 W16) = 821 +primOpTag (VecSubOp WordVec 8 W32) = 822 +primOpTag (VecSubOp WordVec 4 W64) = 823 +primOpTag (VecSubOp WordVec 64 W8) = 824 +primOpTag (VecSubOp WordVec 32 W16) = 825 +primOpTag (VecSubOp WordVec 16 W32) = 826 +primOpTag (VecSubOp WordVec 8 W64) = 827 +primOpTag (VecSubOp FloatVec 4 W32) = 828 +primOpTag (VecSubOp FloatVec 2 W64) = 829 +primOpTag (VecSubOp FloatVec 8 W32) = 830 +primOpTag (VecSubOp FloatVec 4 W64) = 831 +primOpTag (VecSubOp FloatVec 16 W32) = 832 +primOpTag (VecSubOp FloatVec 8 W64) = 833 +primOpTag (VecMulOp IntVec 16 W8) = 834 +primOpTag (VecMulOp IntVec 8 W16) = 835 +primOpTag (VecMulOp IntVec 4 W32) = 836 +primOpTag (VecMulOp IntVec 2 W64) = 837 +primOpTag (VecMulOp IntVec 32 W8) = 838 +primOpTag (VecMulOp IntVec 16 W16) = 839 +primOpTag (VecMulOp IntVec 8 W32) = 840 +primOpTag (VecMulOp IntVec 4 W64) = 841 +primOpTag (VecMulOp IntVec 64 W8) = 842 +primOpTag (VecMulOp IntVec 32 W16) = 843 +primOpTag (VecMulOp IntVec 16 W32) = 844 +primOpTag (VecMulOp IntVec 8 W64) = 845 +primOpTag (VecMulOp WordVec 16 W8) = 846 +primOpTag (VecMulOp WordVec 8 W16) = 847 +primOpTag (VecMulOp WordVec 4 W32) = 848 +primOpTag (VecMulOp WordVec 2 W64) = 849 +primOpTag (VecMulOp WordVec 32 W8) = 850 +primOpTag (VecMulOp WordVec 16 W16) = 851 +primOpTag (VecMulOp WordVec 8 W32) = 852 +primOpTag (VecMulOp WordVec 4 W64) = 853 +primOpTag (VecMulOp WordVec 64 W8) = 854 +primOpTag (VecMulOp WordVec 32 W16) = 855 +primOpTag (VecMulOp WordVec 16 W32) = 856 +primOpTag (VecMulOp WordVec 8 W64) = 857 +primOpTag (VecMulOp FloatVec 4 W32) = 858 +primOpTag (VecMulOp FloatVec 2 W64) = 859 +primOpTag (VecMulOp FloatVec 8 W32) = 860 +primOpTag (VecMulOp FloatVec 4 W64) = 861 +primOpTag (VecMulOp FloatVec 16 W32) = 862 +primOpTag (VecMulOp FloatVec 8 W64) = 863 +primOpTag (VecDivOp FloatVec 4 W32) = 864 +primOpTag (VecDivOp FloatVec 2 W64) = 865 +primOpTag (VecDivOp FloatVec 8 W32) = 866 +primOpTag (VecDivOp FloatVec 4 W64) = 867 +primOpTag (VecDivOp FloatVec 16 W32) = 868 +primOpTag (VecDivOp FloatVec 8 W64) = 869 +primOpTag (VecQuotOp IntVec 16 W8) = 870 +primOpTag (VecQuotOp IntVec 8 W16) = 871 +primOpTag (VecQuotOp IntVec 4 W32) = 872 +primOpTag (VecQuotOp IntVec 2 W64) = 873 +primOpTag (VecQuotOp IntVec 32 W8) = 874 +primOpTag (VecQuotOp IntVec 16 W16) = 875 +primOpTag (VecQuotOp IntVec 8 W32) = 876 +primOpTag (VecQuotOp IntVec 4 W64) = 877 +primOpTag (VecQuotOp IntVec 64 W8) = 878 +primOpTag (VecQuotOp IntVec 32 W16) = 879 +primOpTag (VecQuotOp IntVec 16 W32) = 880 +primOpTag (VecQuotOp IntVec 8 W64) = 881 +primOpTag (VecQuotOp WordVec 16 W8) = 882 +primOpTag (VecQuotOp WordVec 8 W16) = 883 +primOpTag (VecQuotOp WordVec 4 W32) = 884 +primOpTag (VecQuotOp WordVec 2 W64) = 885 +primOpTag (VecQuotOp WordVec 32 W8) = 886 +primOpTag (VecQuotOp WordVec 16 W16) = 887 +primOpTag (VecQuotOp WordVec 8 W32) = 888 +primOpTag (VecQuotOp WordVec 4 W64) = 889 +primOpTag (VecQuotOp WordVec 64 W8) = 890 +primOpTag (VecQuotOp WordVec 32 W16) = 891 +primOpTag (VecQuotOp WordVec 16 W32) = 892 +primOpTag (VecQuotOp WordVec 8 W64) = 893 +primOpTag (VecRemOp IntVec 16 W8) = 894 +primOpTag (VecRemOp IntVec 8 W16) = 895 +primOpTag (VecRemOp IntVec 4 W32) = 896 +primOpTag (VecRemOp IntVec 2 W64) = 897 +primOpTag (VecRemOp IntVec 32 W8) = 898 +primOpTag (VecRemOp IntVec 16 W16) = 899 +primOpTag (VecRemOp IntVec 8 W32) = 900 +primOpTag (VecRemOp IntVec 4 W64) = 901 +primOpTag (VecRemOp IntVec 64 W8) = 902 +primOpTag (VecRemOp IntVec 32 W16) = 903 +primOpTag (VecRemOp IntVec 16 W32) = 904 +primOpTag (VecRemOp IntVec 8 W64) = 905 +primOpTag (VecRemOp WordVec 16 W8) = 906 +primOpTag (VecRemOp WordVec 8 W16) = 907 +primOpTag (VecRemOp WordVec 4 W32) = 908 +primOpTag (VecRemOp WordVec 2 W64) = 909 +primOpTag (VecRemOp WordVec 32 W8) = 910 +primOpTag (VecRemOp WordVec 16 W16) = 911 +primOpTag (VecRemOp WordVec 8 W32) = 912 +primOpTag (VecRemOp WordVec 4 W64) = 913 +primOpTag (VecRemOp WordVec 64 W8) = 914 +primOpTag (VecRemOp WordVec 32 W16) = 915 +primOpTag (VecRemOp WordVec 16 W32) = 916 +primOpTag (VecRemOp WordVec 8 W64) = 917 +primOpTag (VecNegOp IntVec 16 W8) = 918 +primOpTag (VecNegOp IntVec 8 W16) = 919 +primOpTag (VecNegOp IntVec 4 W32) = 920 +primOpTag (VecNegOp IntVec 2 W64) = 921 +primOpTag (VecNegOp IntVec 32 W8) = 922 +primOpTag (VecNegOp IntVec 16 W16) = 923 +primOpTag (VecNegOp IntVec 8 W32) = 924 +primOpTag (VecNegOp IntVec 4 W64) = 925 +primOpTag (VecNegOp IntVec 64 W8) = 926 +primOpTag (VecNegOp IntVec 32 W16) = 927 +primOpTag (VecNegOp IntVec 16 W32) = 928 +primOpTag (VecNegOp IntVec 8 W64) = 929 +primOpTag (VecNegOp FloatVec 4 W32) = 930 +primOpTag (VecNegOp FloatVec 2 W64) = 931 +primOpTag (VecNegOp FloatVec 8 W32) = 932 +primOpTag (VecNegOp FloatVec 4 W64) = 933 +primOpTag (VecNegOp FloatVec 16 W32) = 934 +primOpTag (VecNegOp FloatVec 8 W64) = 935 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 936 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 937 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 938 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 939 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 940 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 941 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 942 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 943 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 944 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 945 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 946 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 947 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 948 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 949 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 950 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 951 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 952 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 953 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 954 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 955 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 956 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 957 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 958 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 959 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 960 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 961 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 962 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 963 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 964 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 965 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 966 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 967 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 968 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 969 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 970 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 971 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 972 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 973 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 974 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 975 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 976 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 977 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 978 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 979 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 980 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 981 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 982 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 983 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 984 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 985 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 986 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 987 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 988 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 989 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 990 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 991 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 992 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 993 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 994 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 995 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 996 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 997 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 998 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 999 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1000 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1001 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1002 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1003 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1004 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1005 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1006 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1007 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1008 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1009 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1010 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1011 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1012 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1013 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1014 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1015 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1016 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1017 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1018 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1019 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1020 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1021 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1022 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1023 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1024 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1025 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1026 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1027 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1028 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1029 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1030 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1031 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1032 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1033 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1034 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1035 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1036 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1037 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1038 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1039 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1040 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1041 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1042 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1043 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1044 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1045 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1046 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1047 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1048 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1049 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1050 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1051 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1052 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1053 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1054 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1055 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1056 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1057 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1058 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1059 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1060 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1061 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1062 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1063 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1064 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1065 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1066 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1067 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1068 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1069 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1070 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1071 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1072 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1073 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1074 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1075 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1076 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1077 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1078 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1079 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1080 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1081 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1082 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1083 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1084 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1085 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1086 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1087 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1088 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1089 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1090 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1091 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1092 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1093 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1094 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1095 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1096 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1097 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1098 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1099 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1100 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1101 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1102 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1103 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1104 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1105 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1106 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1107 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1108 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1109 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1110 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1111 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1112 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1113 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1114 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1115 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1116 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1117 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1118 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1119 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1120 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1121 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1122 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1123 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1124 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1125 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1126 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1127 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1128 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1129 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1130 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1131 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1132 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1133 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1134 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1135 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1136 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1137 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1138 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1139 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1140 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1141 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1142 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1143 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1144 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1145 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1146 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1147 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1148 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1149 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1150 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1151 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1152 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1153 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1154 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1155 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1156 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1157 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1158 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1159 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1160 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1161 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1162 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1163 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1164 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1165 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1166 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1167 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1168 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1169 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1170 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1171 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1172 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1173 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1174 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1175 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1176 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1177 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1178 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1179 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1180 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1181 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1182 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1183 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1184 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1185 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1186 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1187 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1188 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1189 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1190 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1191 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1192 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1193 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1194 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1195 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1196 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1197 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1198 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1199 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1200 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1201 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1202 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1203 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1204 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1205 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1206 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1207 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1208 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1209 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1210 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1211 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1212 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1213 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1214 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1215 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1216 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1217 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1218 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1219 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1220 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1221 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1222 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1223 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1224 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1225 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1226 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1227 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1228 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1229 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1230 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1231 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1232 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1233 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1234 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1235 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1236 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1237 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1238 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1239 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1240 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1241 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1242 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1243 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1244 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1245 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1246 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1247 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1248 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1249 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1250 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1251 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1252 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1253 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1254 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1255 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1256 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1257 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1258 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1259 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1260 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1261 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1262 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1263 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1264 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1265 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1266 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1267 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1268 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1269 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1270 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1271 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1272 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1273 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1274 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1275 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1276 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1277 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1278 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1279 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1280 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1281 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1282 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1283 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1284 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1285 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1286 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1287 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1288 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1289 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1290 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1291 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1292 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1293 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1294 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1295 +primOpTag PrefetchByteArrayOp3 = 1296 +primOpTag PrefetchMutableByteArrayOp3 = 1297 +primOpTag PrefetchAddrOp3 = 1298 +primOpTag PrefetchValueOp3 = 1299 +primOpTag PrefetchByteArrayOp2 = 1300 +primOpTag PrefetchMutableByteArrayOp2 = 1301 +primOpTag PrefetchAddrOp2 = 1302 +primOpTag PrefetchValueOp2 = 1303 +primOpTag PrefetchByteArrayOp1 = 1304 +primOpTag PrefetchMutableByteArrayOp1 = 1305 +primOpTag PrefetchAddrOp1 = 1306 +primOpTag PrefetchValueOp1 = 1307 +primOpTag PrefetchByteArrayOp0 = 1308 +primOpTag PrefetchMutableByteArrayOp0 = 1309 +primOpTag PrefetchAddrOp0 = 1310 +primOpTag PrefetchValueOp0 = 1311 diff --git a/ghc-lib/stage0/lib/llvm-passes b/ghc-lib/stage0/lib/llvm-passes --- a/ghc-lib/stage0/lib/llvm-passes +++ b/ghc-lib/stage0/lib/llvm-passes @@ -1,5 +1,5 @@ [ -(0, "-mem2reg -globalopt -lower-expect"), -(1, "-O1 -globalopt"), -(2, "-O2") +(0, "-enable-new-pm=0 -mem2reg -globalopt -lower-expect"), +(1, "-enable-new-pm=0 -O1 -globalopt"), +(2, "-enable-new-pm=0 -O2") ] diff --git a/ghc-lib/stage0/lib/llvm-targets b/ghc-lib/stage0/lib/llvm-targets --- a/ghc-lib/stage0/lib/llvm-targets +++ b/ghc-lib/stage0/lib/llvm-targets @@ -1,26 +1,29 @@ [("i386-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("i686-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("x86_64-unknown-windows", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) -,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "-vfp2 -vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 -fp64 -d32 -neon -sha2 -aes -dotprod -fp16fml -bf16 -mve.fp -fpregs +strict-align")) -,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) +,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) +,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) +,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) +,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align")) +,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align")) +,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) +,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) +,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) +,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) +,("aarch64_be-unknown-linux-gnu", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) +,("aarch64_be-unknown-linux-musl", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) +,("aarch64_be-unknown-linux", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux-musl", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) @@ -31,29 +34,30 @@ ,("x86_64-unknown-linux-musl", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-android", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16")) -,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon +outline-atomics")) -,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) -,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", "")) -,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", "+secure-plt")) -,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64-S128-v256:256:256-v512:512:512", "ppc64le", "")) +,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) +,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) +,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) +,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", "")) +,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt")) +,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", "")) ,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", "")) -,("riscv64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax -save-restore")) -,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax -save-restore")) -,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) -,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) -,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes")) -,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml")) +,("riscv64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax")) +,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax")) +,("loongarch64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d")) +,("loongarch64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d")) +,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "penryn", "")) +,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", "")) +,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes")) +,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes")) ,("i386-apple-ios", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-ios", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) -,("x86_64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) +,("amd64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) -,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+vfp2 +vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 -d32 -neon -sha2 -aes -fp16fml +strict-align")) -,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "cortex-a8", "+vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -sha2 -aes -fp16fml +strict-align")) +,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) +,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align")) ,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) -,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) -,("i386-unknown-openbsd", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "i586", "")) -,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "-vfp2 -vfp2sp -vfp3 -vfp3d16 -vfp3d16sp -vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 -fp64 -d32 -neon -sha2 -aes -dotprod -fp16fml -bf16 -mve.fp -fpregs +strict-align")) +,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+retpoline-indirect-calls +retpoline-indirect-branches")) +,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ] diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -10,7 +10,6 @@ ,("ld command", "ld") ,("ld flags", "") ,("ld supports compact unwind", "YES") -,("ld supports build-id", "NO") ,("ld supports filelist", "YES") ,("ld is GNU ld", "NO") ,("Merge objects command", "ld") @@ -25,7 +24,6 @@ ,("touch command", "touch") ,("dllwrap command", "/bin/false") ,("windres command", "/bin/false") -,("libtool command", "libtool") ,("unlit command", "$topdir/bin/unlit") ,("cross compiling", "NO") ,("target platform string", "x86_64-apple-darwin") @@ -46,7 +44,7 @@ ,("Use inplace MinGW toolchain", "NO") ,("Use interpreter", "YES") ,("Support SMP", "YES") -,("RTS ways", "v thr") +,("RTS ways", "v") ,("Tables next to code", "YES") ,("Leading underscore", "YES") ,("Use LibFFI", "NO") diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "8e9ea0f91305d9e4bb9df3d89f6a9e223ecb4dd3" +cProjectGitCommitId = "a58c028a181106312e1a783e82a37fc657ce9cfe" cProjectVersion :: String -cProjectVersion = "9.4.8" +cProjectVersion = "9.6.1" cProjectVersionInt :: String -cProjectVersionInt = "904" +cProjectVersionInt = "906" cProjectPatchLevel :: String -cProjectPatchLevel = "8" +cProjectPatchLevel = "1" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "8" +cProjectPatchLevel1 = "1" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0" diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -1,6 +1,6 @@ /* This file is created automatically. Do not edit by hand.*/ -#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" +#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2 @@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24 -#define OFFSET_Capability_lock 1224 +#define OFFSET_Capability_lock 1216 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists] -#define OFFSET_Capability_context_switch 1192 +#define OFFSET_Capability_context_switch 1184 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch] -#define OFFSET_Capability_interrupt 1196 +#define OFFSET_Capability_interrupt 1188 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt] -#define OFFSET_Capability_sparks 1328 +#define OFFSET_Capability_sparks 1320 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks] -#define OFFSET_Capability_total_allocated 1200 +#define OFFSET_Capability_total_allocated 1192 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated] -#define OFFSET_Capability_weak_ptr_list_hd 1176 +#define OFFSET_Capability_weak_ptr_list_hd 1168 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd] -#define OFFSET_Capability_weak_ptr_list_tl 1184 +#define OFFSET_Capability_weak_ptr_list_tl 1176 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0 @@ -111,7 +111,7 @@ #define OFFSET_bdescr_flags 46 #define REP_bdescr_flags b16 #define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags] -#define SIZEOF_generation 384 +#define SIZEOF_generation 368 #define OFFSET_generation_n_new_large_words 56 #define REP_generation_n_new_large_words b64 #define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words] @@ -170,6 +170,11 @@ #define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16) #define SIZEOF_StgStopFrame_NoHdr 0 #define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0) +#define SIZEOF_StgDeadThreadFrame_NoHdr 8 +#define SIZEOF_StgDeadThreadFrame (SIZEOF_StgHeader+8) +#define OFFSET_StgDeadThreadFrame_result 0 +#define REP_StgDeadThreadFrame_result b64 +#define StgDeadThreadFrame_result(__ptr__) REP_StgDeadThreadFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgDeadThreadFrame_result] #define SIZEOF_StgMutArrPtrs_NoHdr 16 #define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16) #define OFFSET_StgMutArrPtrs_ptrs 0 @@ -205,7 +210,7 @@ #define OFFSET_StgTSO_block_info 32 #define REP_StgTSO_block_info b64 #define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info] -#define OFFSET_StgTSO_blocked_exceptions 80 +#define OFFSET_StgTSO_blocked_exceptions 88 #define REP_StgTSO_blocked_exceptions b64 #define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions] #define OFFSET_StgTSO_id 40 @@ -226,13 +231,16 @@ #define OFFSET_StgTSO_dirty 52 #define REP_StgTSO_dirty b32 #define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty] -#define OFFSET_StgTSO_bq 88 +#define OFFSET_StgTSO_bq 96 #define REP_StgTSO_bq b64 #define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq] -#define OFFSET_StgTSO_alloc_limit 96 +#define OFFSET_StgTSO_label 80 +#define REP_StgTSO_label b64 +#define StgTSO_label(__ptr__) REP_StgTSO_label[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_label] +#define OFFSET_StgTSO_alloc_limit 104 #define REP_StgTSO_alloc_limit b64 #define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit] -#define OFFSET_StgTSO_cccs 112 +#define OFFSET_StgTSO_cccs 120 #define REP_StgTSO_cccs b64 #define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs] #define OFFSET_StgTSO_stackobj 16 @@ -293,6 +301,19 @@ #define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun] #define OFFSET_StgAP_STACK_payload 24 #define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)] +#define SIZEOF_StgContinuation_NoHdr 24 +#define SIZEOF_StgContinuation (SIZEOF_StgHeader+24) +#define OFFSET_StgContinuation_apply_mask_frame 0 +#define REP_StgContinuation_apply_mask_frame b64 +#define StgContinuation_apply_mask_frame(__ptr__) REP_StgContinuation_apply_mask_frame[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_apply_mask_frame] +#define OFFSET_StgContinuation_mask_frame_offset 8 +#define REP_StgContinuation_mask_frame_offset b64 +#define StgContinuation_mask_frame_offset(__ptr__) REP_StgContinuation_mask_frame_offset[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_mask_frame_offset] +#define OFFSET_StgContinuation_stack_size 16 +#define REP_StgContinuation_stack_size b64 +#define StgContinuation_stack_size(__ptr__) REP_StgContinuation_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_stack_size] +#define OFFSET_StgContinuation_stack 24 +#define StgContinuation_stack(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_stack + WDS(__ix__)] #define SIZEOF_StgSelector_NoThunkHdr 8 #define SIZEOF_StgSelector_NoHdr 16 #define SIZEOF_StgSelector (SIZEOF_StgHeader+16) diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -85,6 +85,9 @@ significant byte first */ /* #undef FLOAT_WORDS_BIGENDIAN */ +/* Has musttail */ +#define HAS_MUSTTAIL 1 + /* Has visibility hidden */ #define HAS_VISIBILITY_HIDDEN 1 @@ -129,6 +132,10 @@ don't. */ /* #undef HAVE_DECL_MAP_NORESERVE */ +/* Define to 1 if you have the declaration of `program_invocation_short_name', + and to 0 if you don't. */ +#define HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME 0 + /* Define to 1 if you have the header file. */ #define HAVE_DIRENT_H 1 @@ -162,12 +169,18 @@ /* Define to 1 if you have the `GetModuleFileName' function. */ /* #undef HAVE_GETMODULEFILENAME */ +/* Define to 1 if you have the `getpid' function. */ +#define HAVE_GETPID 1 + /* Define to 1 if you have the `getrusage' function. */ #define HAVE_GETRUSAGE 1 /* Define to 1 if you have the `gettimeofday' function. */ #define HAVE_GETTIMEOFDAY 1 +/* Define to 1 if you have the `getuid' function. */ +#define HAVE_GETUID 1 + /* Define to 1 if you have the header file. */ #define HAVE_GRP_H 1 @@ -186,9 +199,6 @@ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 -/* Define to 1 if you have the `mingwex' library (-lmingwex). */ -/* #undef HAVE_LIBMINGWEX */ - /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 @@ -246,6 +256,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_PWD_H 1 +/* Define to 1 if you have the `raise' function. */ +#define HAVE_RAISE 1 + /* Define to 1 if you have the `sched_getaffinity' function. */ /* #undef HAVE_SCHED_GETAFFINITY */ @@ -345,9 +358,6 @@ /* Define to 1 if you have the `times' function. */ #define HAVE_TIMES 1 -/* Define to 1 if you have the header file. */ -#define HAVE_TIME_H 1 - /* Define to 1 if you have the header file. */ #define HAVE_UNISTD_H 1 @@ -491,10 +501,6 @@ /* Define to 1 if info tables are laid out next to code */ #define TABLES_NEXT_TO_CODE 1 -/* Define to 1 if you can safely include both and . This - macro is obsolete. */ -#define TIME_WITH_SYS_TIME 1 - /* Compile-in ASSERTs in all ways. */ /* #undef USE_ASSERTS_ALL_WAYS */ @@ -626,10 +632,10 @@ /* #undef pid_t */ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (15) +#define sUPPORTED_LLVM_VERSION_MAX (16) /* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (10) +#define sUPPORTED_LLVM_VERSION_MIN (11) /* Define to `unsigned int' if does not define. */ /* #undef size_t */ diff --git a/ghc/ghc-bin.cabal b/ghc/ghc-bin.cabal new file mode 100644 --- /dev/null +++ b/ghc/ghc-bin.cabal @@ -0,0 +1,98 @@ +-- WARNING: ghc-bin.cabal is automatically generated from ghc-bin.cabal.in by +-- ./configure. Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal. + +Name: ghc-bin +Version: 9.6.1 +Copyright: XXX +-- License: XXX +-- License-File: XXX +Author: XXX +Maintainer: glasgow-haskell-users@haskell.org +Homepage: http://www.haskell.org/ghc/ +Synopsis: The Glorious Glasgow Haskell Compiler. +Description: + This package contains the @ghc@ executable, the user facing front-end + to the Glasgow Haskell Compiler. +Category: Development +Build-Type: Simple +Cabal-Version: >=1.10 + +Flag internal-interpreter + Description: Build with internal interpreter support. + Default: False + Manual: True + +Flag threaded + Description: Link the ghc executable against the threaded RTS + Default: True + Manual: True + +Executable ghc + Default-Language: Haskell2010 + + Main-Is: Main.hs + Build-Depends: base >= 4 && < 5, + array >= 0.1 && < 0.6, + bytestring >= 0.9 && < 0.12, + directory >= 1 && < 1.4, + process >= 1 && < 1.7, + filepath >= 1 && < 1.5, + containers >= 0.5 && < 0.7, + transformers >= 0.5 && < 0.7, + ghc-boot == 9.6.1, + ghc == 9.6.1 + + if os(windows) + Build-Depends: Win32 >= 2.3 && < 2.14 + else + Build-Depends: unix >= 2.7 && < 2.9 + + GHC-Options: -Wall + -Wnoncanonical-monad-instances + -Wnoncanonical-monoid-instances + -rtsopts=all + "-with-rtsopts=-K512M -H -I5 -T" + + if flag(internal-interpreter) + -- NB: this is never built by the bootstrapping GHC+libraries + Build-depends: + deepseq == 1.4.*, + ghc-prim >= 0.5.0 && < 0.11, + ghci == 9.6.1, + haskeline == 0.8.*, + exceptions == 0.10.*, + time >= 1.8 && < 1.13 + CPP-Options: -DHAVE_INTERNAL_INTERPRETER + Other-Modules: + GHCi.Leak + GHCi.UI + GHCi.UI.Info + GHCi.UI.Monad + GHCi.UI.Tags + GHCi.Util + Other-Extensions: + FlexibleInstances + LambdaCase + MagicHash + MultiWayIf + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + UnboxedTuples + ViewPatterns + + if flag(threaded) + ghc-options: -threaded + + Other-Extensions: + CPP + NondecreasingIndentation + TupleSections + + -- This should match the default-extensions used in 'ghc.cabal'. This way, + -- GHCi can be used to load it all at once. + Default-Extensions: + NoImplicitPrelude + , ScopedTypeVariables + , BangPatterns diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs --- a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs +++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs @@ -13,5 +13,6 @@ | LangObjc -- ^ Objective C | LangObjcxx -- ^ Objective C++ | LangAsm -- ^ Assembly language (.s) + | LangJs -- ^ JavaScript | RawObject -- ^ Object (.o) deriving (Eq, Show, Generic) diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -56,7 +56,7 @@ | BangPatterns | TypeFamilies | TypeFamilyDependencies - | TypeInType + | TypeInType -- Deprecated | OverloadedStrings | OverloadedLists | NumDecimals @@ -73,6 +73,7 @@ | ConstraintKinds | PolyKinds -- Kind polymorphism | DataKinds -- Datatype promotion + | TypeData -- allow @type data@ definitions | InstanceSigs | ApplicativeDo | LinearTypes diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal b/libraries/ghc-boot-th/ghc-boot-th.cabal new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot-th/ghc-boot-th.cabal @@ -0,0 +1,39 @@ +-- WARNING: ghc-boot-th.cabal is automatically generated from +-- ghc-boot-th.cabal.in by ../../configure. Make sure you are editing +-- ghc-boot-th.cabal.in, not ghc-boot-th.cabal. + +name: ghc-boot-th +version: 9.6.1 +license: BSD3 +license-file: LICENSE +category: GHC +maintainer: ghc-devs@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +synopsis: Shared functionality between GHC and the @template-haskell@ + library +description: This library contains various bits shared between the @ghc@ and + @template-haskell@ libraries. + . + This package exists to ensure that @template-haskell@ has a + minimal set of transitive dependencies, since it is intended to + be depended upon by user code. +cabal-version: >=1.10 +build-type: Simple +extra-source-files: changelog.md + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/ghc-boot-th + +Library + default-language: Haskell2010 + other-extensions: DeriveGeneric + default-extensions: NoImplicitPrelude + + exposed-modules: + GHC.LanguageExtensions.Type + GHC.ForeignSrcLang.Type + GHC.Lexeme + + build-depends: base >= 4.7 && < 4.19 diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs --- a/libraries/ghc-boot/GHC/BaseDir.hs +++ b/libraries/ghc-boot/GHC/BaseDir.hs @@ -17,6 +17,7 @@ import Prelude -- See Note [Why do we import Prelude here?] import Data.List (stripPrefix) +import Data.Maybe (listToMaybe) import System.FilePath -- Windows @@ -37,7 +38,7 @@ expandPathVar :: String -> FilePath -> String -> String expandPathVar var value str | Just str' <- stripPrefix ('$':var) str - , null str' || isPathSeparator (head str') + , maybe True isPathSeparator (listToMaybe str') = value ++ expandPathVar var value str' expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] diff --git a/libraries/ghc-boot/GHC/Data/ShortText.hs b/libraries/ghc-boot/GHC/Data/ShortText.hs --- a/libraries/ghc-boot/GHC/Data/ShortText.hs +++ b/libraries/ghc-boot/GHC/Data/ShortText.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies, CPP #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- gross hack: we manuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore. +-- gross hack: we maneuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore. -- LLVM based GHC's fail to compile memcmp ffi calls. These end up as memcmp$def in the llvm ir, however we -- don't have any prototypes and subsequently the llvm toolchain chokes on them. Since 7fdcce6d, we use -- ShortText for the package database. This however introduces this very module; which through inlining ends @@ -10,7 +10,7 @@ -- The solution thusly is to force late binding via the linker instead of inlining when comping with the -- bootstrap compiler. This will produce a slower (slightly less optimised) stage1 compiler only. -- --- See issue 18857. hsyl20 deserves credit for coming up with the idea for the soltuion. +-- See issue 18857. hsyl20 deserves credit for coming up with the idea for the solution. -- -- This can be removed when we exit the boot compiler window. Thus once we drop GHC-9.2 as boot compiler, -- we can drop this code as well. @@ -29,6 +29,7 @@ -- * ShortText ShortText(..), -- ** Conversion to and from String + singleton, pack, unpack, -- ** Operations @@ -67,15 +68,20 @@ -- | /O(n)/ Returns the length of the 'ShortText' in characters. codepointLength :: ShortText -> Int -codepointLength st = unsafeDupablePerformIO $ countUTF8Chars (contents st) +codepointLength st = utf8CountCharsShortByteString (contents st) + -- | /O(1)/ Returns the length of the 'ShortText' in bytes. byteLength :: ShortText -> Int byteLength st = SBS.length $ contents st -- | /O(n)/ Convert a 'String' into a 'ShortText'. pack :: String -> ShortText -pack s = unsafeDupablePerformIO $ ShortText <$> utf8EncodeShortByteString s +pack s = ShortText $ utf8EncodeShortByteString s +-- | Create a singleton +singleton :: Char -> ShortText +singleton s = pack [s] + -- | /O(n)/ Convert a 'ShortText' into a 'String'. unpack :: ShortText -> String unpack st = utf8DecodeShortByteString $ contents st @@ -100,8 +106,10 @@ -- non-printable characters. head :: ShortText -> Char head st - | SBS.null $ contents st = error "head: Empty ShortText" - | otherwise = Prelude.head $ unpack st + | hd:_ <- unpack st + = hd + | otherwise + = error "head: Empty ShortText" -- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of -- the second iff the first is its prefix, and otherwise Nothing. diff --git a/libraries/ghc-boot/GHC/Platform/ArchOS.hs b/libraries/ghc-boot/GHC/Platform/ArchOS.hs --- a/libraries/ghc-boot/GHC/Platform/ArchOS.hs +++ b/libraries/ghc-boot/GHC/Platform/ArchOS.hs @@ -44,7 +44,9 @@ | ArchMipseb | ArchMipsel | ArchRISCV64 + | ArchLoongArch64 | ArchJavaScript + | ArchWasm32 deriving (Read, Show, Eq, Ord) -- | ARM Instruction Set Architecture @@ -95,6 +97,7 @@ | OSQNXNTO | OSAIX | OSHurd + | OSWasi deriving (Read, Show, Eq, Ord) @@ -132,7 +135,9 @@ ArchMipseb -> "mipseb" ArchMipsel -> "mipsel" ArchRISCV64 -> "riscv64" - ArchJavaScript -> "js" + ArchLoongArch64 -> "loongarch64" + ArchJavaScript -> "javascript" + ArchWasm32 -> "wasm32" -- | See Note [Platform Syntax]. stringEncodeOS :: OS -> String @@ -151,3 +156,4 @@ OSQNXNTO -> "nto-qnx" OSAIX -> "aix" OSHurd -> "hurd" + OSWasi -> "wasi" diff --git a/libraries/ghc-boot/GHC/Settings/Utils.hs b/libraries/ghc-boot/GHC/Settings/Utils.hs new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/GHC/Settings/Utils.hs @@ -0,0 +1,72 @@ +module GHC.Settings.Utils where + +import Prelude -- See Note [Why do we import Prelude here?] + +import Data.Char (isSpace) +import Data.Map (Map) +import qualified Data.Map as Map + +import GHC.BaseDir +import GHC.Platform.ArchOS + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] | all isSpace s -> Just x + _ -> Nothing + + +-- Note [Settings file] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time +-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU +-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is +-- associated with the current version/target platform. +-- +-- This module has just enough code to read key value pairs from the settings +-- file, and read the target platform from those pairs. + +type RawSettings = Map String String + +-- | Read target Arch/OS from the settings +getTargetArchOS + :: FilePath -- ^ Settings filepath (for error messages) + -> RawSettings -- ^ Raw settings file contents + -> Either String ArchOS +getTargetArchOS settingsFile settings = + ArchOS <$> readRawSetting settingsFile settings "target arch" + <*> readRawSetting settingsFile settings "target os" + + +getRawSetting + :: FilePath -> RawSettings -> String -> Either String String +getRawSetting settingsFile settings key = case Map.lookup key settings of + Just xs -> Right xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile + +getRawFilePathSetting + :: FilePath -> FilePath -> RawSettings -> String -> Either String String +getRawFilePathSetting top_dir settingsFile settings key = + expandTopDir top_dir <$> getRawSetting settingsFile settings key + +getRawBooleanSetting + :: FilePath -> RawSettings -> String -> Either String Bool +getRawBooleanSetting settingsFile settings key = do + rawValue <- getRawSetting settingsFile settings key + case rawValue of + "YES" -> Right True + "NO" -> Right False + xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs + +readRawSetting + :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a +readRawSetting settingsFile settings key = case Map.lookup key settings of + Just xs -> case maybeRead xs of + Just v -> Right v + Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile diff --git a/libraries/ghc-boot/GHC/Utils/Encoding.hs b/libraries/ghc-boot/GHC/Utils/Encoding.hs --- a/libraries/ghc-boot/GHC/Utils/Encoding.hs +++ b/libraries/ghc-boot/GHC/Utils/Encoding.hs @@ -17,23 +17,11 @@ module GHC.Utils.Encoding ( -- * UTF-8 - utf8DecodeCharAddr#, - utf8PrevChar, - utf8CharStart, - utf8DecodeChar, - utf8DecodeByteString, - utf8UnconsByteString, - utf8DecodeShortByteString, - utf8CompareShortByteString, - utf8DecodeStringLazy, - utf8EncodeChar, - utf8EncodeString, - utf8EncodeStringPtr, - utf8EncodeShortByteString, - utf8EncodedLength, - countUTF8Chars, + module GHC.Utils.Encoding.UTF8, -- * Z-encoding + UserString, + EncodedString, zEncodeString, zDecodeString, @@ -45,295 +33,11 @@ import Prelude import Foreign -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Data.Char import qualified Data.Char as Char import Numeric -import GHC.IO -import GHC.ST -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import Data.ByteString.Short.Internal (ShortByteString(..)) - -import GHC.Exts - --- ----------------------------------------------------------------------------- --- UTF-8 - --- We can't write the decoder as efficiently as we'd like without --- resorting to unboxed extensions, unfortunately. I tried to write --- an IO version of this function, but GHC can't eliminate boxed --- results from an IO-returning function. --- --- We assume we can ignore overflow when parsing a multibyte character here. --- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences --- before decoding them (see "GHC.Data.StringBuffer"). - -{-# INLINE utf8DecodeChar# #-} -utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #) -utf8DecodeChar# indexWord8# = - let !ch0 = word2Int# (indexWord8# 0#) in - case () of - _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) - - | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> - let !ch1 = word2Int# (indexWord8# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ch1 -# 0x80#)), - 2# #) - - | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> - let !ch1 = word2Int# (indexWord8# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch2 -# 0x80#)), - 3# #) - - | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> - let !ch1 = word2Int# (indexWord8# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - let !ch3 = word2Int# (indexWord8# 3#) in - if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else - (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch3 -# 0x80#)), - 4# #) - - | otherwise -> fail 1# - where - -- all invalid sequences end up here: - fail :: Int# -> (# Char#, Int# #) - fail nBytes# = (# '\0'#, nBytes# #) - -- '\xFFFD' would be the usual replacement character, but - -- that's a valid symbol in Haskell, so will result in a - -- confusing parse error later on. Instead we use '\0' which - -- will signal a lexer error immediately. - -utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #) -utf8DecodeCharAddr# a# off# = -#if !MIN_VERSION_base(4,16,0) - utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#)) -#else - utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#))) -#endif - -utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #) -utf8DecodeCharByteArray# ba# off# = -#if !MIN_VERSION_base(4,16,0) - utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#)) -#else - utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#))) -#endif - - -utf8DecodeChar :: Ptr Word8 -> (Char, Int) -utf8DecodeChar !(Ptr a#) = - case utf8DecodeCharAddr# a# 0# of - (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) - --- UTF-8 is cleverly designed so that we can always figure out where --- the start of the current character is, given any position in a --- stream. This function finds the start of the previous character, --- assuming there *is* a previous character. -utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) -utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) - -utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) -utf8CharStart p = go p - where go p = do w <- peek p - if w >= 0x80 && w < 0xC0 - then go (p `plusPtr` (-1)) - else return p - -{-# INLINE utf8DecodeLazy# #-} -utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char] -utf8DecodeLazy# retain decodeChar# len# - = unpack 0# - where - unpack i# - | isTrue# (i# >=# len#) = retain >> return [] - | otherwise = - case decodeChar# i# of - (# c#, nBytes# #) -> do - rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#) - return (C# c# : rest) - -utf8DecodeByteString :: ByteString -> [Char] -utf8DecodeByteString (BS.PS fptr offset len) - = utf8DecodeStringLazy fptr offset len - -utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString) -utf8UnconsByteString (BS.PS _ _ 0) = Nothing -utf8UnconsByteString (BS.PS fptr offset len) - = unsafeDupablePerformIO $ - withForeignPtr fptr $ \ptr -> do - let (c,n) = utf8DecodeChar (ptr `plusPtr` offset) - return $ Just (c, BS.PS fptr (offset + n) (len - n)) - -utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] -utf8DecodeStringLazy fp offset (I# len#) - = unsafeDupablePerformIO $ do - let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset - utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len# --- Note that since utf8DecodeLazy# returns a thunk the lifetime of the --- ForeignPtr actually needs to be longer than the lexical lifetime --- withForeignPtr would provide here. That's why we use touchForeignPtr to --- keep the fp alive until the last character has actually been decoded. - -utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering -utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0# - -- UTF-8 has the property that sorting by bytes values also sorts by - -- code-points. - -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property - -- doesn't hold and we must explicitly check this case here. - -- Note that decoding every code point would also work but it would be much - -- more costly. - where - !sz1 = sizeofByteArray# a1 - !sz2 = sizeofByteArray# a2 - go off1 off2 - | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ - | isTrue# (off1 >=# sz1) = LT - | isTrue# (off2 >=# sz2) = GT - | otherwise = -#if !MIN_VERSION_base(4,16,0) - let !b1_1 = indexWord8Array# a1 off1 - !b2_1 = indexWord8Array# a2 off2 -#else - let !b1_1 = word8ToWord# (indexWord8Array# a1 off1) - !b2_1 = word8ToWord# (indexWord8Array# a2 off2) -#endif - in case b1_1 of - 0xC0## -> case b2_1 of - 0xC0## -> go (off1 +# 1#) (off2 +# 1#) -#if !MIN_VERSION_base(4,16,0) - _ -> case indexWord8Array# a1 (off1 +# 1#) of -#else - _ -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of -#endif - 0x80## -> LT - _ -> go (off1 +# 1#) (off2 +# 1#) - _ -> case b2_1 of -#if !MIN_VERSION_base(4,16,0) - 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of -#else - 0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of -#endif - 0x80## -> GT - _ -> go (off1 +# 1#) (off2 +# 1#) - _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT - | isTrue# (b1_1 `ltWord#` b2_1) -> LT - | otherwise -> go (off1 +# 1#) (off2 +# 1#) - -utf8DecodeShortByteString :: ShortByteString -> [Char] -utf8DecodeShortByteString (SBS ba#) - = unsafeDupablePerformIO $ - let len# = sizeofByteArray# ba# in - utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len# - -countUTF8Chars :: ShortByteString -> IO Int -countUTF8Chars (SBS ba) = go 0# 0# - where - len# = sizeofByteArray# ba - go i# n# - | isTrue# (i# >=# len#) = - return (I# n#) - | otherwise = do - case utf8DecodeCharByteArray# ba i# of - (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#) - -{-# INLINE utf8EncodeChar #-} -utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s) - -> Char -> ST s Int -utf8EncodeChar write# c = - let x = fromIntegral (ord c) in - case () of - _ | x > 0 && x <= 0x007f -> do - write 0 x - return 1 - -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we - -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). - | x <= 0x07ff -> do - write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F)) - write 1 (0x80 .|. (x .&. 0x3F)) - return 2 - | x <= 0xffff -> do - write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F) - write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F) - write 2 (0x80 .|. (x .&. 0x3F)) - return 3 - | otherwise -> do - write 0 (0xF0 .|. (x `shiftR` 18)) - write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F)) - write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F)) - write 3 (0x80 .|. (x .&. 0x3F)) - return 4 - where - {-# INLINE write #-} - write (I# off#) (W# c#) = ST $ \s -> -#if !MIN_VERSION_base(4,16,0) - case write# off# (narrowWord8# c#) s of -#else - case write# off# (wordToWord8# c#) s of -#endif - s -> (# s, () #) - -utf8EncodeString :: String -> ByteString -utf8EncodeString s = - unsafePerformIO $ do - let len = utf8EncodedLength s - buf <- mallocForeignPtrBytes len - withForeignPtr buf $ \ptr -> do - utf8EncodeStringPtr ptr s - pure (BS.fromForeignPtr buf 0 len) - -utf8EncodeStringPtr :: Ptr Word8 -> String -> IO () -utf8EncodeStringPtr (Ptr a#) str = go a# str - where go !_ [] = return () - go a# (c:cs) = do -#if !MIN_VERSION_base(4,16,0) - -- writeWord8OffAddr# was taking a Word# - I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c -#else - I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c -#endif - go (a# `plusAddr#` off#) cs - -utf8EncodeShortByteString :: String -> IO ShortByteString -utf8EncodeShortByteString str = IO $ \s -> - case utf8EncodedLength str of { I# len# -> - case newByteArray# len# s of { (# s, mba# #) -> - case go mba# 0# str of { ST f_go -> - case f_go s of { (# s, () #) -> - case unsafeFreezeByteArray# mba# s of { (# s, ba# #) -> - (# s, SBS ba# #) }}}}} - where - go _ _ [] = return () - go mba# i# (c:cs) = do -#if !MIN_VERSION_base(4,16,0) - -- writeWord8Array# was taking a Word# - I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c -#else - I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c -#endif - go mba# (i# +# off#) cs - -utf8EncodedLength :: String -> Int -utf8EncodedLength str = go 0 str - where go !n [] = n - go n (c:cs) - | ord c > 0 && ord c <= 0x007f = go (n+1) cs - | ord c <= 0x07ff = go (n+2) cs - | ord c <= 0xffff = go (n+3) cs - | otherwise = go (n+4) cs +import GHC.Utils.Encoding.UTF8 -- ----------------------------------------------------------------------------- -- Note [Z-Encoding] @@ -441,8 +145,10 @@ encode_ch c = encode_as_unicode_char c encode_as_unicode_char :: Char -> EncodedString -encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str - else '0':hex_str +encode_as_unicode_char c = 'z' : case hex_str of + hd : _ + | isDigit hd -> hex_str + _ -> '0' : hex_str where hex_str = showHex (ord c) "U" -- ToDo: we could improve the encoding here in various ways. -- eg. strings of unicode characters come out as 'z1234Uz5678U', we diff --git a/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs b/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} +{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected. This module used to live in the `ghc` +-- package but has been moved to `ghc-boot` because the definition +-- of the package database (needed in both ghc and in ghc-pkg) lives in +-- `ghc-boot` and uses ShortText, which in turn depends on this module. + +-- | Simple, non-streaming UTF-8 codecs. +-- +-- This is one of several UTF-8 implementations provided by GHC; see Note +-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an +-- overview. +-- +module GHC.Utils.Encoding.UTF8 + ( -- * Decoding single characters + utf8DecodeCharAddr# + , utf8DecodeCharPtr + , utf8DecodeCharByteArray# + , utf8PrevChar + , utf8CharStart + , utf8UnconsByteString + -- * Decoding strings + , utf8DecodeByteString + , utf8DecodeShortByteString + , utf8DecodeForeignPtr + , utf8DecodeByteArray# + -- * Counting characters + , utf8CountCharsShortByteString + , utf8CountCharsByteArray# + -- * Comparison + , utf8CompareByteArray# + , utf8CompareShortByteString + -- * Encoding strings + , utf8EncodeByteArray# + , utf8EncodePtr + , utf8EncodeByteString + , utf8EncodeShortByteString + , utf8EncodedLength + ) where + + +import Prelude + +import Foreign +import GHC.IO +#if MIN_VERSION_base(4,18,0) +import GHC.Encoding.UTF8 +#else +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Data.Char +import GHC.Exts +import GHC.ST +#endif + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import Data.ByteString.Short.Internal (ShortByteString(..)) + +-- | Find the start of the codepoint preceding the codepoint at the given +-- 'Ptr'. This is undefined if there is no previous valid codepoint. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +-- | Find the start of the codepoint at the given 'Ptr'. This is undefined if +-- there is no previous valid codepoint. +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +utf8CountCharsShortByteString :: ShortByteString -> Int +utf8CountCharsShortByteString (SBS ba) = utf8CountCharsByteArray# ba + +utf8DecodeShortByteString :: ShortByteString -> [Char] +utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba# + +-- | Decode a 'ByteString' containing a UTF-8 string. +utf8DecodeByteString :: ByteString -> [Char] +utf8DecodeByteString (BS.PS fptr offset len) + = utf8DecodeForeignPtr fptr offset len + +utf8EncodeShortByteString :: String -> ShortByteString +utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str) + +-- | Encode a 'String' into a 'ByteString'. +utf8EncodeByteString :: String -> ByteString +utf8EncodeByteString s = + unsafePerformIO $ do + let len = utf8EncodedLength s + buf <- mallocForeignPtrBytes len + withForeignPtr buf $ \ptr -> do + utf8EncodePtr ptr s + pure (BS.fromForeignPtr buf 0 len) + +utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString) +utf8UnconsByteString (BS.PS _ _ 0) = Nothing +utf8UnconsByteString (BS.PS fptr offset len) + = unsafeDupablePerformIO $ + withForeignPtr fptr $ \ptr -> do + let (c,n) = utf8DecodeCharPtr (ptr `plusPtr` offset) + return $ Just (c, BS.PS fptr (offset + n) (len - n)) + +utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering +utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2 + +--------------------------------------------------------- +-- Everything below was moved into base in GHC 9.6 +-- +-- These can be dropped in GHC 9.6 + 2 major releases. +--------------------------------------------------------- + +#if !MIN_VERSION_base(4,18,0) + +-- We can't write the decoder as efficiently as we'd like without +-- resorting to unboxed extensions, unfortunately. I tried to write +-- an IO version of this function, but GHC can't eliminate boxed +-- results from an IO-returning function. +-- +-- We assume we can ignore overflow when parsing a multibyte character here. +-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences +-- before decoding them (see "GHC.Data.StringBuffer"). + +{-# INLINE utf8DecodeChar# #-} +-- | Decode a single codepoint from a byte buffer indexed by the given indexing +-- function. +utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #) +utf8DecodeChar# indexWord8# = + let !ch0 = word2Int# (indexWord8# 0#) in + case () of + _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) + + | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ch1 -# 0x80#)), + 2# #) + + | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch2 -# 0x80#)), + 3# #) + + | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + let !ch3 = word2Int# (indexWord8# 3#) in + if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else + (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch3 -# 0x80#)), + 4# #) + + | otherwise -> fail 1# + where + -- all invalid sequences end up here: + fail :: Int# -> (# Char#, Int# #) + fail nBytes# = (# '\0'#, nBytes# #) + -- '\xFFFD' would be the usual replacement character, but + -- that's a valid symbol in Haskell, so will result in a + -- confusing parse error later on. Instead we use '\0' which + -- will signal a lexer error immediately. + +-- | Decode a single character at the given 'Addr#'. +utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #) +utf8DecodeCharAddr# a# off# = +#if !MIN_VERSION_base(4,16,0) + utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#)) +#else + utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#))) +#endif + +-- | Decode a single codepoint starting at the given 'Ptr'. +utf8DecodeCharPtr :: Ptr Word8 -> (Char, Int) +utf8DecodeCharPtr !(Ptr a#) = + case utf8DecodeCharAddr# a# 0# of + (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) + +-- | Decode a single codepoint starting at the given byte offset into a +-- 'ByteArray#'. +utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #) +utf8DecodeCharByteArray# ba# off# = +#if !MIN_VERSION_base(4,16,0) + utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#)) +#else + utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#))) +#endif + +{-# INLINE utf8Decode# #-} +utf8Decode# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char] +utf8Decode# retain decodeChar# len# + = unpack 0# + where + unpack i# + | isTrue# (i# >=# len#) = retain >> return [] + | otherwise = + case decodeChar# i# of + (# c#, nBytes# #) -> do + rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#) + return (C# c# : rest) + +utf8DecodeForeignPtr :: ForeignPtr Word8 -> Int -> Int -> [Char] +utf8DecodeForeignPtr fp offset (I# len#) + = unsafeDupablePerformIO $ do + let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset + utf8Decode# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len# +-- Note that since utf8Decode# returns a thunk the lifetime of the +-- ForeignPtr actually needs to be longer than the lexical lifetime +-- withForeignPtr would provide here. That's why we use touchForeignPtr to +-- keep the fp alive until the last character has actually been decoded. + +utf8DecodeByteArray# :: ByteArray# -> [Char] +utf8DecodeByteArray# ba# + = unsafeDupablePerformIO $ + let len# = sizeofByteArray# ba# in + utf8Decode# (return ()) (utf8DecodeCharByteArray# ba#) len# + +utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering +utf8CompareByteArray# a1 a2 = go 0# 0# + -- UTF-8 has the property that sorting by bytes values also sorts by + -- code-points. + -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property + -- doesn't hold and we must explicitly check this case here. + -- Note that decoding every code point would also work but it would be much + -- more costly. + where + !sz1 = sizeofByteArray# a1 + !sz2 = sizeofByteArray# a2 + go off1 off2 + | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ + | isTrue# (off1 >=# sz1) = LT + | isTrue# (off2 >=# sz2) = GT + | otherwise = +#if !MIN_VERSION_base(4,16,0) + let !b1_1 = indexWord8Array# a1 off1 + !b2_1 = indexWord8Array# a2 off2 +#else + let !b1_1 = word8ToWord# (indexWord8Array# a1 off1) + !b2_1 = word8ToWord# (indexWord8Array# a2 off2) +#endif + in case b1_1 of + 0xC0## -> case b2_1 of + 0xC0## -> go (off1 +# 1#) (off2 +# 1#) +#if !MIN_VERSION_base(4,16,0) + _ -> case indexWord8Array# a1 (off1 +# 1#) of +#else + _ -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of +#endif + 0x80## -> LT + _ -> go (off1 +# 1#) (off2 +# 1#) + _ -> case b2_1 of +#if !MIN_VERSION_base(4,16,0) + 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of +#else + 0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of +#endif + 0x80## -> GT + _ -> go (off1 +# 1#) (off2 +# 1#) + _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT + | isTrue# (b1_1 `ltWord#` b2_1) -> LT + | otherwise -> go (off1 +# 1#) (off2 +# 1#) + +utf8CountCharsByteArray# :: ByteArray# -> Int +utf8CountCharsByteArray# ba = go 0# 0# + where + len# = sizeofByteArray# ba + go i# n# + | isTrue# (i# >=# len#) = I# n# + | otherwise = + case utf8DecodeCharByteArray# ba i# of + (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#) + +{-# INLINE utf8EncodeChar #-} +utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s) + -> Char -> ST s Int +utf8EncodeChar write# c = + let x = fromIntegral (ord c) in + case () of + _ | x > 0 && x <= 0x007f -> do + write 0 x + return 1 + -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we + -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). + | x <= 0x07ff -> do + write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F)) + write 1 (0x80 .|. (x .&. 0x3F)) + return 2 + | x <= 0xffff -> do + write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F) + write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F) + write 2 (0x80 .|. (x .&. 0x3F)) + return 3 + | otherwise -> do + write 0 (0xF0 .|. (x `shiftR` 18)) + write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F)) + write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F)) + write 3 (0x80 .|. (x .&. 0x3F)) + return 4 + where + {-# INLINE write #-} + write (I# off#) (W# c#) = ST $ \s -> +#if !MIN_VERSION_base(4,16,0) + case write# off# (narrowWord8# c#) s of +#else + case write# off# (wordToWord8# c#) s of +#endif + s -> (# s, () #) + +utf8EncodePtr :: Ptr Word8 -> String -> IO () +utf8EncodePtr (Ptr a#) str = go a# str + where go !_ [] = return () + go a# (c:cs) = do +#if !MIN_VERSION_base(4,16,0) + -- writeWord8OffAddr# was taking a Word# + I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c +#else + I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c +#endif + go (a# `plusAddr#` off#) cs + +utf8EncodeByteArray# :: String -> ByteArray# +utf8EncodeByteArray# str = runRW# $ \s -> + case utf8EncodedLength str of { I# len# -> + case newByteArray# len# s of { (# s, mba# #) -> + case go mba# 0# str of { ST f_go -> + case f_go s of { (# s, () #) -> + case unsafeFreezeByteArray# mba# s of { (# _, ba# #) -> + ba# }}}}} + where + go _ _ [] = return () + go mba# i# (c:cs) = do +#if !MIN_VERSION_base(4,16,0) + -- writeWord8Array# was taking a Word# + I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c +#else + I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c +#endif + go mba# (i# +# off#) cs + +utf8EncodedLength :: String -> Int +utf8EncodedLength str = go 0 str + where go !n [] = n + go n (c:cs) + | ord c > 0 && ord c <= 0x007f = go (n+1) cs + | ord c <= 0x07ff = go (n+2) cs + | ord c <= 0xffff = go (n+3) cs + | otherwise = go (n+4) cs + +#endif /* MIN_VERSION_base(4,18,0) */ diff --git a/libraries/ghc-boot/ghc-boot.cabal b/libraries/ghc-boot/ghc-boot.cabal new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/ghc-boot.cabal @@ -0,0 +1,83 @@ +cabal-version: 3.0 + +-- WARNING: ghc-boot.cabal is automatically generated from ghc-boot.cabal.in by +-- ../../configure. Make sure you are editing ghc-boot.cabal.in, not +-- ghc-boot.cabal. + +name: ghc-boot +version: 9.6.1 +license: BSD-3-Clause +license-file: LICENSE +category: GHC +maintainer: ghc-devs@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +synopsis: Shared functionality between GHC and its boot libraries +description: This library is shared between GHC, ghc-pkg, and other boot + libraries. + . + A note about "GHC.Unit.Database": it only deals with the subset of + the package database that the compiler cares about: modules + paths etc and not package metadata like description, authors + etc. It is thus not a library interface to ghc-pkg and is *not* + suitable for modifying GHC package databases. + . + The package database format and this library are constructed in + such a way that while ghc-pkg depends on Cabal, the GHC library + and program do not have to depend on Cabal. +build-type: Custom +extra-source-files: changelog.md + +custom-setup + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, filepath + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/ghc-boot + +Library + default-language: Haskell2010 + other-extensions: DeriveGeneric, RankNTypes, ScopedTypeVariables + default-extensions: NoImplicitPrelude + + exposed-modules: + GHC.BaseDir + GHC.Data.ShortText + GHC.Data.SizedSeq + GHC.Utils.Encoding + GHC.Utils.Encoding.UTF8 + GHC.LanguageExtensions + GHC.Unit.Database + GHC.Serialized + GHC.ForeignSrcLang + GHC.HandleEncoding + GHC.Platform.ArchOS + GHC.Platform.Host + GHC.Settings.Utils + GHC.UniqueSubdir + GHC.Version + + -- reexport modules from ghc-boot-th so that packages don't have to import + -- both ghc-boot and ghc-boot-th. It makes the dependency graph easier to + -- understand and to refactor. + reexported-modules: + GHC.LanguageExtensions.Type + , GHC.ForeignSrcLang.Type + , GHC.Lexeme + + -- but done by Hadrian + autogen-modules: + GHC.Version + GHC.Platform.Host + + build-depends: base >= 4.7 && < 4.19, + binary == 0.8.*, + bytestring >= 0.10 && < 0.12, + containers >= 0.5 && < 0.7, + directory >= 1.2 && < 1.4, + filepath >= 1.3 && < 1.5, + deepseq >= 1.4 && < 1.5, + ghc-boot-th == 9.6.1 + if !os(windows) + build-depends: + unix >= 2.7 && < 2.9 diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -3,7 +3,8 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnliftedFFITypes #-} @@ -70,7 +71,6 @@ import qualified GHC.Exts.Heap.FFIClosures as FFIClosures import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI -import Control.Monad import Data.Bits import Foreign import GHC.Exts @@ -220,136 +220,120 @@ t | t >= THUNK && t <= THUNK_STATIC -> do pure $ ThunkClosure itbl pts npts - THUNK_SELECTOR -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to THUNK_SELECTOR" - pure $ SelectorClosure itbl (head pts) + THUNK_SELECTOR -> case pts of + [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR" + hd : _ -> pure $ SelectorClosure itbl hd t | t >= FUN && t <= FUN_STATIC -> do pure $ FunClosure itbl pts npts - AP -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to AP" - -- We expect at least the arity, n_args, and fun fields - unless (length payloadWords >= 2) $ - fail "Expected at least 2 raw words to AP" - let splitWord = payloadWords !! 0 - pure $ APClosure itbl + AP -> case pts of + [] -> fail "Expected at least 1 ptr argument to AP" + hd : tl -> case payloadWords of + -- We expect at least the arity, n_args, and fun fields + splitWord : _ : _ -> + pure $ APClosure itbl #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (head pts) (tail pts) + hd tl + _ -> fail "Expected at least 2 raw words to AP" - PAP -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to PAP" - -- We expect at least the arity, n_args, and fun fields - unless (length payloadWords >= 2) $ - fail "Expected at least 2 raw words to PAP" - let splitWord = payloadWords !! 0 - pure $ PAPClosure itbl + PAP -> case pts of + [] -> fail "Expected at least 1 ptr argument to PAP" + hd : tl -> case payloadWords of + -- We expect at least the arity, n_args, and fun fields + splitWord : _ : _ -> + pure $ PAPClosure itbl #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (head pts) (tail pts) + hd tl + _ -> fail "Expected at least 2 raw words to PAP" - AP_STACK -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to AP_STACK" - pure $ APStackClosure itbl (head pts) (tail pts) + AP_STACK -> case pts of + [] -> fail "Expected at least 1 ptr argument to AP_STACK" + hd : tl -> pure $ APStackClosure itbl hd tl - IND -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to IND" - pure $ IndClosure itbl (head pts) + IND -> case pts of + [] -> fail "Expected at least 1 ptr argument to IND" + hd : _ -> pure $ IndClosure itbl hd - IND_STATIC -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to IND_STATIC" - pure $ IndClosure itbl (head pts) + IND_STATIC -> case pts of + [] -> fail "Expected at least 1 ptr argument to IND_STATIC" + hd : _ -> pure $ IndClosure itbl hd - BLACKHOLE -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to BLACKHOLE" - pure $ BlackholeClosure itbl (head pts) + BLACKHOLE -> case pts of + [] -> fail "Expected at least 1 ptr argument to BLACKHOLE" + hd : _ -> pure $ BlackholeClosure itbl hd - BCO -> do - unless (length pts >= 3) $ - fail $ "Expected at least 3 ptr argument to BCO, found " - ++ show (length pts) - unless (length payloadWords >= 4) $ - fail $ "Expected at least 4 words to BCO, found " - ++ show (length payloadWords) - let splitWord = payloadWords !! 3 - pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) + BCO -> case pts of + pts0 : pts1 : pts2 : _ -> case payloadWords of + _ : _ : _ : splitWord : payloadRest -> + pure $ BCOClosure itbl pts0 pts1 pts2 #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (drop 4 payloadWords) + payloadRest + _ -> fail $ "Expected at least 4 words to BCO, found " + ++ show (length payloadWords) + _ -> fail $ "Expected at least 3 ptr argument to BCO, found " + ++ show (length pts) - ARR_WORDS -> do - unless (length payloadWords >= 1) $ - fail $ "Expected at least 1 words to ARR_WORDS, found " + ARR_WORDS -> case payloadWords of + [] -> fail $ "Expected at least 1 words to ARR_WORDS, found " ++ show (length payloadWords) - pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords) + hd : tl -> pure $ ArrWordsClosure itbl hd tl - t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length payloadWords >= 2) $ - fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " + t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of + p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts + _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " ++ "found " ++ show (length payloadWords) - pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts - t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length payloadWords >= 1) $ - fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " + t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of + [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " ++ "found " ++ show (length payloadWords) - pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts + hd : _ -> pure $ SmallMutArrClosure itbl hd pts - t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do - unless (length pts >= 1) $ - fail $ "Expected at least 1 words to MUT_VAR, found " + t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of + [] -> fail $ "Expected at least 1 words to MUT_VAR, found " ++ show (length pts) - pure $ MutVarClosure itbl (head pts) + hd : _ -> pure $ MutVarClosure itbl hd - t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do - unless (length pts >= 3) $ - fail $ "Expected at least 3 ptrs to MVAR, found " + t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of + pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2 + _ -> fail $ "Expected at least 3 ptrs to MVAR, found " ++ show (length pts) - pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) BLOCKING_QUEUE -> pure $ OtherClosure itbl pts rawHeapWords - -- pure $ BlockingQueueClosure itbl - -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) - -- pure $ OtherClosure itbl pts rawHeapWords - -- - WEAK -> do - pure $ WeakClosure + WEAK -> case pts of + pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure { info = itbl - , cfinalizers = pts !! 0 - , key = pts !! 1 - , value = pts !! 2 - , finalizer = pts !! 3 - , weakLink = case drop 4 pts of + , cfinalizers = pts0 + , key = pts1 + , value = pts2 + , finalizer = pts3 + , weakLink = case rest of [] -> Nothing [p] -> Just p - _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts) + _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts) } - TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts + _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts) + TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts -> withArray rawHeapWords (\ptr -> do fields <- FFIClosures.peekTSOFields decodeCCS ptr pure $ TSOClosure @@ -360,6 +344,10 @@ , trec = u_trec , blocked_exceptions = u_blk_ex , bq = u_bq + , thread_label = case other of + [tl] -> Just tl + [] -> Nothing + _ -> error $ "thead_label:Expected 0 or 1 extra arguments" , what_next = FFIClosures.tso_what_next fields , why_blocked = FFIClosures.tso_why_blocked fields , flags = FFIClosures.tso_flags fields @@ -371,7 +359,7 @@ , prof = FFIClosures.tso_prof fields }) | otherwise - -> fail $ "Expected 6 ptr arguments to TSO, found " + -> fail $ "Expected at least 6 ptr arguments to TSO, found " ++ show (length pts) STACK | [] <- pts diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs @@ -80,6 +80,7 @@ | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA + | CONTINUATION | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -280,6 +280,7 @@ , trec :: !b , blocked_exceptions :: !b , bq :: !b + , thread_label :: !(Maybe b) -- values , what_next :: !WhatNext , why_blocked :: !WhyBlocked diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc --- a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc +++ b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc @@ -110,11 +110,7 @@ (m, occ) = (intercalate "." $ reverse modWords, occWord) where - (modWords, occWord) = - if length rest1 < 1 -- XXXXXXXXx YUKX - --then error "getConDescAddress:parse:length rest1 < 1" - then parseModOcc [] [] - else parseModOcc [] (tail rest1) + (modWords, occWord) = parseModOcc [] (drop 1 rest1) -- We only look for dots if str could start with a module name, -- i.e. if it starts with an upper case character. -- Otherwise we might think that "X.:->" is the module name in diff --git a/libraries/ghc-heap/ghc-heap.cabal b/libraries/ghc-heap/ghc-heap.cabal new file mode 100644 --- /dev/null +++ b/libraries/ghc-heap/ghc-heap.cabal @@ -0,0 +1,50 @@ +cabal-version: 3.0 +name: ghc-heap +version: 9.6.1 +license: BSD-3-Clause +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +synopsis: Functions for walking GHC's heap +category: GHC +description: + This package provides functions for walking the GHC heap data structures + and retrieving information about those data structures. + +build-type: Simple +tested-with: GHC==7.11 + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/ghc-heap + +library + default-language: Haskell2010 + + build-depends: base >= 4.9.0 && < 5.0 + , ghc-prim > 0.2 && < 0.11 + , rts == 1.0.* + , containers >= 0.6.2.1 && < 0.7 + + ghc-options: -Wall + if !os(ghcjs) + cmm-sources: cbits/HeapPrim.cmm + + default-extensions: NoImplicitPrelude + + exposed-modules: GHC.Exts.Heap + GHC.Exts.Heap.Closures + GHC.Exts.Heap.ClosureTypes + GHC.Exts.Heap.Constants + GHC.Exts.Heap.InfoTable + GHC.Exts.Heap.InfoTable.Types + GHC.Exts.Heap.InfoTableProf + GHC.Exts.Heap.Utils + GHC.Exts.Heap.FFIClosures + GHC.Exts.Heap.FFIClosures_ProfilingDisabled + GHC.Exts.Heap.FFIClosures_ProfilingEnabled + GHC.Exts.Heap.ProfInfo.Types + GHC.Exts.Heap.ProfInfo.PeekProfInfo + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc --- a/libraries/ghci/GHCi/FFI.hsc +++ b/libraries/ghci/GHCi/FFI.hsc @@ -6,15 +6,24 @@ -- ----------------------------------------------------------------------------- --- See Note [FFI_GO_CLOSURES workaround] in ghc_ffi.h --- We can't include ghc_ffi.h here as we must build with stage0 -#if defined(darwin_HOST_OS) -#if !defined(FFI_GO_CLOSURES) -#define FFI_GO_CLOSURES 0 -#endif -#endif +{- Note [FFI for the JS-Backend] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The JS-backend does not use GHC's native rts, as such you might think that it + doesn't require ghci. However, that is not true, because we need ghci in + order to interoperate with iserv even if we do not use any of the FFI stuff + in this file. So obviously we do not require libffi, but we still need to be + able to build ghci in order for the JS-Backend to supply its own iserv + interop solution. Thus we bite the bullet and wrap all the unneeded bits in a + CPP conditional compilation blocks that detect the JS-backend. A necessary + evil to be sure; notice that the only symbols remaining the JS_HOST_ARCH case + are those that are explicitly exported by this module and set to error if + they are every used. +-} + +#if !defined(javascript_HOST_ARCH) #include +#endif {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-} module GHCi.FFI @@ -26,11 +35,13 @@ ) where import Prelude -- See note [Why do we import Prelude here?] +#if !defined(javascript_HOST_ARCH) import Control.Exception +import Foreign.C +#endif import Data.Binary import GHC.Generics import Foreign -import Foreign.C data FFIType = FFIVoid @@ -59,6 +70,7 @@ -> FFIType -- result type -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller) +#if !defined(javascript_HOST_ARCH) prepForeignCall cconv arg_types result_type = do let n_args = length arg_types arg_arr <- mallocArray n_args @@ -74,12 +86,27 @@ " res ty: ", show result_type, ")" ] else return (castPtr cif) +#else +prepForeignCall _ _ _ = + error "GHCi.FFI.prepForeignCall: Called with JS_HOST_ARCH! Perhaps you need to run configure?" +#endif + freeForeignCallInfo :: Ptr C_ffi_cif -> IO () +#if !defined(javascript_HOST_ARCH) freeForeignCallInfo p = do free ((#ptr ffi_cif, arg_types) p) free p +#else +freeForeignCallInfo _ = + error "GHCi.FFI.freeForeignCallInfo: Called with JS_HOST_ARCH! Perhaps you need to run configure?" +#endif +data C_ffi_cif + +#if !defined(javascript_HOST_ARCH) +data C_ffi_type + strError :: C_ffi_status -> String strError r | r == fFI_BAD_ABI @@ -111,9 +138,6 @@ ffiType FFIUInt32 = ffi_type_uint32 ffiType FFIUInt64 = ffi_type_uint64 -data C_ffi_type -data C_ffi_cif - type C_ffi_status = (#type ffi_status) type C_ffi_abi = (#type ffi_abi) @@ -169,3 +193,4 @@ -- -> Ptr () -- put result here -- -> Ptr (Ptr ()) -- arg values -- -> IO () +#endif diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -464,8 +464,8 @@ #ifndef MIN_VERSION_ghc_heap #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ - (major1) == 9 && (major2) < 4 || \ - (major1) == 9 && (major2) == 4 && (minor) <= 8) + (major1) == 9 && (major2) < 6 || \ + (major1) == 9 && (major2) == 6 && (minor) <= 1) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo @@ -624,7 +624,7 @@ go Nothing (Partial fun) = do -- putStrLn "before hGetSome" b <- B.hGetSome h (32*1024) - -- printf "hGetSome: %d\n" (B.length b) + -- putStrLn $ "hGetSome: " ++ show (B.length b) if B.null b then return Nothing else go Nothing (fun (Just b)) diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal new file mode 100644 --- /dev/null +++ b/libraries/ghci/ghci.cabal @@ -0,0 +1,86 @@ +-- WARNING: ghci.cabal is automatically generated from ghci.cabal.in by +-- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. + +name: ghci +version: 9.6.1 +license: BSD3 +license-file: LICENSE +category: GHC +maintainer: ghc-devs@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +synopsis: The library supporting GHC's interactive interpreter +description: + This library offers interfaces which mediate interactions between the + @ghci@ interactive shell and @iserv@, GHC's out-of-process interpreter + backend. +cabal-version: >=1.10 +build-type: Simple +extra-source-files: changelog.md + +Flag internal-interpreter + Description: Build with internal interpreter support. + Default: False + Manual: True + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/ghci + +library + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + other-extensions: + BangPatterns + CPP + DeriveGeneric + ExistentialQuantification + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + MagicHash + MultiParamTypeClasses + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + UnboxedTuples + + if flag(internal-interpreter) + CPP-Options: -DHAVE_INTERNAL_INTERPRETER + exposed-modules: + GHCi.InfoTable + GHCi.Run + GHCi.CreateBCO + GHCi.ObjLink + GHCi.Signals + GHCi.StaticPtrTable + GHCi.TH + + exposed-modules: + GHCi.BreakArray + GHCi.BinaryArray + GHCi.Message + GHCi.ResolvedBCO + GHCi.RemoteTypes + GHCi.FFI + GHCi.TH.Binary + + Build-Depends: + rts, + array == 0.5.*, + base >= 4.8 && < 4.19, + ghc-prim >= 0.5.0 && < 0.11, + binary == 0.8.*, + bytestring >= 0.10 && < 0.12, + containers >= 0.5 && < 0.7, + deepseq == 1.4.*, + filepath == 1.4.*, + ghc-boot == 9.6.1, + ghc-heap == 9.6.1, + template-haskell == 2.20.*, + transformers >= 0.5 && < 0.7 + + if !os(windows) + Build-Depends: unix >= 2.7 && < 2.9 diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -1,7 +1,7 @@ {- | The public face of Template Haskell For other documentation, refer to: - + -} {-# LANGUAGE Safe #-} diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -86,7 +86,7 @@ -- *** Top Level Declarations -- **** Data - valD, funD, tySynD, dataD, newtypeD, + valD, funD, tySynD, dataD, newtypeD, typeDataD, derivClause, DerivClause(..), stockStrategy, anyclassStrategy, newtypeStrategy, viaStrategy, DerivStrategy(..), @@ -131,8 +131,8 @@ thisModule, -- ** Documentation - withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc, - newtypeInstD_doc, patSynD_doc + withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, + typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc ) where @@ -140,6 +140,7 @@ ( tySynD , dataD , newtypeD + , typeDataD , classD , pragRuleD , dataInstD @@ -178,10 +179,10 @@ import qualified Language.Haskell.TH.Lib.Internal as Internal import Language.Haskell.TH.Syntax -import Control.Applicative ( liftA2 ) +import Control.Applicative (Applicative(..)) import Foreign.ForeignPtr import Data.Word -import Prelude +import Prelude hiding (Applicative(..)) -- All definitions below represent the "old" API, since their definitions are -- different in Language.Haskell.TH.Lib.Internal. Please think carefully before @@ -211,6 +212,13 @@ con1 <- con derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) + +typeDataD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] + -> m Dec +typeDataD tc tvs ksig cons = + do + cons1 <- sequenceA cons + return (TypeDataD tc tvs ksig cons1) classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -20,12 +20,12 @@ import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH -import Control.Applicative(liftA, liftA2) +import Control.Applicative(liftA, Applicative(..)) import qualified Data.Kind as Kind (Type) import Data.Word( Word8 ) import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts (TYPE) -import Prelude +import Prelude hiding (Applicative(..)) ---------------------------------------------------------- -- * Type synonyms @@ -441,6 +441,15 @@ derivs1 <- sequenceA derivs pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) +typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] + -> m Dec +typeDataD tc tvs ksig cons = + do + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + pure (TypeDataD tc tvs1 ksig1 cons1) + classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do @@ -1033,6 +1042,7 @@ doc_loc (ValD (VarP n) _ _) = Just $ DeclDoc n doc_loc (DataD _ n _ _ _ _) = Just $ DeclDoc n doc_loc (NewtypeD _ n _ _ _ _) = Just $ DeclDoc n + doc_loc (TypeDataD n _ _ _) = Just $ DeclDoc n doc_loc (TySynD n _ _) = Just $ DeclDoc n doc_loc (ClassD _ n _ _ _) = Just $ DeclDoc n doc_loc (SigD n _) = Just $ DeclDoc n @@ -1106,6 +1116,19 @@ newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do qAddModFinalizer $ docCons con_with_docs let dec = newtypeD ctxt tc tvs ksig con derivs + maybe dec (flip withDecDoc dec) mdoc + +-- | Variant of 'typeDataD' that attaches Haddock documentation. +typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) + -> [(Q Con, Maybe String, [Maybe String])] + -- ^ List of constructors, documentation for the constructor, and + -- documentation for the arguments + -> Maybe String + -- ^ Documentation to attach to the data declaration + -> Q Dec +typeDataD_doc tc tvs ksig cons_with_docs mdoc = do + qAddModFinalizer $ mapM_ docCons cons_with_docs + let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) maybe dec (flip withDecDoc dec) mdoc -- | Variant of 'dataInstD' that attaches Haddock documentation. diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -23,10 +23,12 @@ nestDepth = 4 type Precedence = Int -appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence -appPrec = 4 -- Argument of a function application -opPrec = 3 -- Argument of an infix operator -unopPrec = 2 -- Argument of an unresolved infix operator +appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence +appPrec = 6 -- Argument of a function or type application +opPrec = 5 -- Argument of an infix operator +unopPrec = 4 -- Argument of an unresolved infix operator +funPrec = 3 -- Argument of a function arrow +qualPrec = 2 -- Forall-qualified type or result of a function arrow sigPrec = 1 -- Argument of an explicit type signature noPrec = 0 -- Others @@ -220,7 +222,7 @@ pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e - <+> dcolon <+> ppr t + <+> dcolon <+> pprType sigPrec t pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ @@ -397,6 +399,8 @@ = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs ppr_dec _ (NewtypeD ctxt t xs ksig c decs) = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs +ppr_dec _ (TypeDataD t xs ksig cs) + = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs [] ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -493,6 +497,10 @@ -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs +ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] + -> Doc +ppr_type_data = ppr_typedef "type data" + ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs = sep [text data_or_newtype <+> maybeInst @@ -792,60 +800,63 @@ pprStrictType = pprBangType ------------------------------ -pprParendType :: Type -> Doc -pprParendType (VarT v) = pprName' Applied v +pprType :: Precedence -> Type -> Doc +pprType _ (VarT v) = pprName' Applied v -- `Applied` is used here instead of `ppr` because of infix names (#13887) -pprParendType (ConT c) = pprName' Applied c -pprParendType (TupleT 0) = text "()" -pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) -pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) -pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma -pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar -pprParendType ArrowT = parens (text "->") -pprParendType MulArrowT = text "FUN" -pprParendType ListT = text "[]" -pprParendType (LitT l) = pprTyLit l -pprParendType (PromotedT c) = text "'" <> pprName' Applied c -pprParendType (PromotedTupleT 0) = text "'()" -pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) -pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) -pprParendType PromotedNilT = text "'[]" -pprParendType PromotedConsT = text "'(:)" -pprParendType StarT = char '*' -pprParendType ConstraintT = text "Constraint" -pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) -pprParendType WildCardT = char '_' -pprParendType t@(InfixT {}) = parens (pprInfixT t) -pprParendType t@(UInfixT {}) = parens (pprInfixT t) -pprParendType t@(PromotedInfixT {}) = parens (pprInfixT t) -pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t) -pprParendType (ParensT t) = ppr t -pprParendType tuple | (TupleT n, args) <- split tuple - , length args == n - = parens (commaSep args) -pprParendType (ImplicitParamT n t) = text ('?':n) <+> text "::" <+> ppr t -pprParendType EqualityT = text "(~)" -pprParendType t@(ForallT {}) = parens (ppr t) -pprParendType t@(ForallVisT {}) = parens (ppr t) -pprParendType t@(AppT {}) = parens (ppr t) -pprParendType t@(AppKindT {}) = parens (ppr t) +pprType _ (ConT c) = pprName' Applied c +pprType _ (TupleT 0) = text "()" +pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1)) +pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma)) +pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma +pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar +pprType _ ArrowT = parens (text "->") +pprType _ MulArrowT = text "FUN" +pprType _ ListT = text "[]" +pprType _ (LitT l) = pprTyLit l +pprType _ (PromotedT c) = text "'" <> pprName' Applied c +pprType _ (PromotedTupleT 0) = text "'()" +pprType p (PromotedTupleT 1) = pprType p (PromotedT (tupleDataName 1)) +pprType _ (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) +pprType _ PromotedNilT = text "'[]" +pprType _ PromotedConsT = text "'(:)" +pprType _ StarT = char '*' +pprType _ ConstraintT = text "Constraint" +pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) +pprType _ WildCardT = char '_' +pprType p t@(InfixT {}) = pprInfixT p t +pprType p t@(UInfixT {}) = pprInfixT p t +pprType p t@(PromotedInfixT {}) = pprInfixT p t +pprType p t@(PromotedUInfixT {}) = pprInfixT p t +pprType _ (ParensT t) = parens (pprType noPrec t) +pprType p (ImplicitParamT n ty) = + parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty +pprType _ EqualityT = text "(~)" +pprType p (ForallT tvars ctxt ty) = + parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty] +pprType p (ForallVisT tvars ty) = + parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty] +pprType p t@AppT{} = pprTyApp p (split t) +pprType p t@AppKindT{} = pprTyApp p (split t) -pprInfixT :: Type -> Doc -pprInfixT = \case - (InfixT x n y) -> with x n y "" ppr - (UInfixT x n y) -> with x n y "" pprInfixT - (PromotedInfixT x n y) -> with x n y "'" ppr - (PromotedUInfixT x n y) -> with x n y "'" pprInfixT - t -> ppr t +------------------------------ +pprParendType :: Type -> Doc +pprParendType = pprType appPrec + +pprInfixT :: Precedence -> Type -> Doc +pprInfixT p = \case + InfixT x n y -> with x n y "" opPrec + UInfixT x n y -> with x n y "" unopPrec + PromotedInfixT x n y -> with x n y "'" opPrec + PromotedUInfixT x n y -> with x n y "'" unopPrec + t -> pprParendType t where - with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y + with x n y prefix p' = + parensIf + (p >= p') + (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y) instance Ppr Type where - ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] - ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty] - ppr ty = pprTyApp (split ty) - -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind) - -- See Note [Pretty-printing kind signatures] + ppr = pprType noPrec instance Ppr TypeArg where ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty) ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki) @@ -866,38 +877,40 @@ type instance F Int = (Bool :: *) So we always print a SigT with parens (see #10050). -} -pprTyApp :: (Type, [TypeArg]) -> Doc -pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2]) - | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", ppr arg2] - | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) = - sep [pprFunArgType arg1 <+> text "%" <> ppr argm <+> text "->", ppr arg2] -pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = - sep [pprFunArgType arg1 <+> text "~", ppr arg2] -pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) -pprTyApp (TupleT 1, args) = pprTyApp (ConT (tupleTypeName 1), args) -pprTyApp (PromotedTupleT 1, args) = pprTyApp (PromotedT (tupleDataName 1), args) -pprTyApp (TupleT n, args) +pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc +pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2]) + | p >= funPrec = parens (pprTyApp noPrec app) + | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2] + | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2] +pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) = + parensIf (p >= funPrec) $ + sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->", + pprType qualPrec arg2] +pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) = + parensIf (p >= funPrec) $ + sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2] +pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) = + parensIf (p >= opPrec) $ + sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2] +pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg) +pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args) +pprTyApp _ (TupleT n, args) | length args == n, Just args' <- traverse fromTANormal args = parens (commaSep args') -pprTyApp (PromotedTupleT n, args) +pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args) +pprTyApp _ (PromotedTupleT n, args) | length args == n, Just args' <- traverse fromTANormal args = quoteParens (commaSep args') -pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) +pprTyApp p (fun, args) = + parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args) fromTANormal :: TypeArg -> Maybe Type fromTANormal (TANormal arg) = Just arg fromTANormal (TyArg _) = Nothing -pprFunArgType :: Type -> Doc -- Should really use a precedence argument --- Everything except forall and (->) binds more tightly than (->) -pprFunArgType ty@(ForallT {}) = parens (ppr ty) -pprFunArgType ty@(ForallVisT {}) = parens (ppr ty) -pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty) -pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) -pprFunArgType ty@(SigT _ _) = parens (ppr ty) -pprFunArgType ty = ppr ty +-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->). +pprFunArgType :: Type -> Doc +pprFunArgType = pprType funPrec data ForallVisFlag = ForallVis -- forall a -> {...} | ForallInvis -- forall a. {...} diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2,7 +2,7 @@ DeriveGeneric, FlexibleInstances, DefaultSignatures, RankNTypes, RoleAnnotations, ScopedTypeVariables, MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds, - GADTs, UnboxedTuples, UnboxedSums, TypeInType, TypeOperators, + GADTs, UnboxedTuples, UnboxedSums, TypeOperators, Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} @@ -26,6 +26,9 @@ -- * Language extensions , module Language.Haskell.TH.LanguageExtensions , ForeignSrcLang(..) + -- * Notes + -- ** Unresolved Infix + -- $infix ) where import Data.Data hiding (Fixity(..)) @@ -36,7 +39,7 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fix (MonadFix (..)) -import Control.Applicative (liftA2) +import Control.Applicative (Applicative(..)) import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO) import Control.Exception.Base (FixIOException (..)) import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) @@ -57,7 +60,7 @@ import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions import Numeric.Natural -import Prelude +import Prelude hiding (Applicative(..)) import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types @@ -639,7 +642,8 @@ newDeclarationGroup :: Q [Dec] newDeclarationGroup = pure [] -{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, +{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible") +of @nm tys@. That is, if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family, all instances of this family at the types @tys@ are returned. @@ -657,9 +661,21 @@ There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given). -An instance is visible if it is imported or defined in a prior top-level -declaration group. See the documentation for 'newDeclarationGroup' for more details. +In principle, the *visible* instances are +* all instances defined in a prior top-level declaration group + (see docs on @newDeclarationGroup@), or +* all instances defined in any module transitively imported by the + module being compiled +However, actually searching all modules transitively below the one being +compiled is unreasonably expensive, so @reifyInstances@ will report only the +instance for modules that GHC has had some cause to visit during this +compilation. This is a shortcoming: @reifyInstances@ might fail to report +instances for a type that is otherwise unusued, or instances defined in a +different component. You can work around this shortcoming by explicitly importing the modules +whose instances you want to be visible. GHC issue +has some discussion around this. + -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) @@ -811,6 +827,7 @@ LangObjc -> "m" LangObjcxx -> "mm" LangAsm -> "s" + LangJs -> "js" RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src @@ -1117,8 +1134,9 @@ where helper :: HasCallStack => Name helper = - case head (getCallStack ?callStack) of - (_, SrcLoc{..}) -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" + case getCallStack ?callStack of + [] -> error "addrToByteArrayName: empty call stack" + (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" addrToByteArray :: Int -> Addr# -> ByteArray @@ -1398,7 +1416,7 @@ con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") - (mkModName "GHC.Tuple")) + (mkModName "GHC.Tuple.Prim")) -- Tricky case: see Note [Data for non-algebraic types] fun@(x:_) | startsVarSym x || startsVarId x @@ -1789,6 +1807,10 @@ mkNameL :: String -> Uniq -> Name mkNameL s u = Name (mkOccName s) (NameL u) +-- | Only used internally +mkNameQ :: String -> String -> Name +mkNameQ mn occ = Name (mkOccName occ) (NameQ (mkModName mn)) + -- | Used for 'x etc, but not available to the programmer mkNameG :: NameSpace -> String -> String -> String -> Name mkNameG ns pkg modu occ @@ -1870,10 +1892,13 @@ withParens thing | boxed = "(" ++ thing ++ ")" | otherwise = "(#" ++ thing ++ "#)" - tup_occ | n == 1 = if boxed then "Solo" else "Solo#" + tup_occ | n == 1 = if boxed then solo else "Solo#" | otherwise = withParens (replicate n_commas ',') n_commas = n - 1 - tup_mod = mkModName "GHC.Tuple" + tup_mod = mkModName "GHC.Tuple.Prim" + solo + | space == DataName = "MkSolo" + | otherwise = "Solo" -- Unboxed sum data and type constructors -- | Unboxed sum data constructor @@ -2070,6 +2095,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~ -} {- $infix #infix# + When implementing antiquotation for quasiquoters, one often wants to parse strings into expressions: @@ -2377,6 +2403,9 @@ Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ + | TypeDataD Name [TyVarBndr ()] + (Maybe Kind) -- Kind signature (allowed only for GADTs) + [Con] -- ^ @{ type data T x = A x | B (T x) }@ | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr ()] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ @@ -2597,24 +2626,36 @@ -- be tuples of other constraints. type Pred = Type +-- | 'SourceUnpackedness' corresponds to unpack annotations found in the source code. +-- +-- This may not agree with the annotations returned by 'reifyConStrictness'. +-- See 'reifyConStrictness' for more information. data SourceUnpackedness = NoSourceUnpackedness -- ^ @C a@ | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ deriving (Show, Eq, Ord, Data, Generic) +-- | 'SourceStrictness' corresponds to strictness annotations found in the source code. +-- +-- This may not agree with the annotations returned by 'reifyConStrictness'. +-- See 'reifyConStrictness' for more information. data SourceStrictness = NoSourceStrictness -- ^ @C a@ | SourceLazy -- ^ @C {~}a@ | SourceStrict -- ^ @C {!}a@ deriving (Show, Eq, Ord, Data, Generic) -- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' --- refers to the strictness that the compiler chooses for a data constructor --- field, which may be different from what is written in source code. See --- 'reifyConStrictness' for more information. -data DecidedStrictness = DecidedLazy - | DecidedStrict - | DecidedUnpack +-- refers to the strictness annotations that the compiler chooses for a data constructor +-- field, which may be different from what is written in source code. +-- +-- Note that non-unpacked strict fields are assigned 'DecidedLazy' when a bang would be inappropriate, +-- such as the field of a newtype constructor and fields that have an unlifted type. +-- +-- See 'reifyConStrictness' for more information. +data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang. + | DecidedStrict -- ^ Field inferred to have a bang. + | DecidedUnpack -- ^ Field inferred to be unpacked. deriving (Show, Eq, Ord, Data, Generic) -- | A single data constructor. @@ -2740,21 +2781,21 @@ | ParensT Type -- ^ @(T)@ -- See Note [Representing concrete syntax in types] - | TupleT Int -- ^ @(,), (,,), etc.@ - | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ - | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ + | TupleT Int -- ^ @(,)@, @(,,)@, etc. + | UnboxedTupleT Int -- ^ @(\#,\#)@, @(\#,,\#)@, etc. + | UnboxedSumT SumArity -- ^ @(\#|\#)@, @(\#||\#)@, etc. | ArrowT -- ^ @->@ | MulArrowT -- ^ @%n ->@ -- -- Generalised arrow type with multiplicity argument | EqualityT -- ^ @~@ | ListT -- ^ @[]@ - | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ + | PromotedTupleT Int -- ^ @'()@, @'(,)@, @'(,,)@, etc. | PromotedNilT -- ^ @'[]@ - | PromotedConsT -- ^ @(':)@ + | PromotedConsT -- ^ @'(:)@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ - | LitT TyLit -- ^ @0,1,2, etc.@ + | LitT TyLit -- ^ @0@, @1@, @2@, etc. | WildCardT -- ^ @_@ | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal new file mode 100644 --- /dev/null +++ b/libraries/template-haskell/template-haskell.cabal @@ -0,0 +1,73 @@ +-- WARNING: template-haskell.cabal is automatically generated from template-haskell.cabal.in by +-- ../../configure. Make sure you are editing template-haskell.cabal.in, not +-- template-haskell.cabal. + +name: template-haskell +version: 2.20.0.0 +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE +category: Template Haskell +maintainer: libraries@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +synopsis: Support library for Template Haskell +build-type: Simple +Cabal-Version: >= 1.10 +description: + This package provides modules containing facilities for manipulating + Haskell source code using Template Haskell. + . + See for more + information. + +extra-source-files: changelog.md + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/template-haskell + +Library + default-language: Haskell2010 + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveGeneric + FlexibleInstances + RankNTypes + RoleAnnotations + ScopedTypeVariables + + exposed-modules: + Language.Haskell.TH + Language.Haskell.TH.Lib + Language.Haskell.TH.Ppr + Language.Haskell.TH.PprLib + Language.Haskell.TH.Quote + Language.Haskell.TH.Syntax + Language.Haskell.TH.LanguageExtensions + Language.Haskell.TH.CodeDo + Language.Haskell.TH.Lib.Internal + + other-modules: + Language.Haskell.TH.Lib.Map + + build-depends: + base >= 4.11 && < 4.19, + ghc-boot-th == 9.6.1, + ghc-prim, + pretty == 1.1.* + + build-depends: + filepath + hs-source-dirs: . + default-extensions: + ImplicitPrelude + + ghc-options: -Wall + + -- We need to set the unit ID to template-haskell (without a + -- version number) as it's magic. + ghc-options: -this-unit-id template-haskell