ghc-lib-parser 0.20210201 → 0.20210228

raw patch · 104 files changed

+13756/−12659 lines, 104 filesdep ~basedep ~ghc-prim

Dependency ranges changed: base, ghc-prim

Files

• compiler/GHC/Builtin/Names.hs +101/−61
• compiler/GHC/Builtin/PrimOps.hs +1/−1
• compiler/GHC/Builtin/Types.hs +28/−5
• compiler/GHC/Builtin/Types.hs-boot +1/−0
• compiler/GHC/Builtin/Types/Prim.hs +34/−13
• compiler/GHC/Cmm/CLabel.hs +1/−1
• compiler/GHC/Cmm/Expr.hs +1/−1
• compiler/GHC/Cmm/Type.hs +1/−1
• compiler/GHC/Core.hs +1/−0
• compiler/GHC/Core/FamInstEnv.hs +4/−3
• compiler/GHC/Core/InstEnv.hs +19/−31
• compiler/GHC/Core/Lint.hs +74/−64
• compiler/GHC/Core/Make.hs +7/−1
• compiler/GHC/Core/Map/Type.hs +14/−10
• compiler/GHC/Core/Opt/Arity.hs +2/−2
• compiler/GHC/Core/Opt/ConstantFold.hs +9/−10
• compiler/GHC/Core/Opt/Monad.hs +27/−22
• compiler/GHC/Core/Opt/OccurAnal.hs +19/−11
• compiler/GHC/Core/SimpleOpt.hs +14/−3
• compiler/GHC/Core/TyCo/FVs.hs +1/−1
• compiler/GHC/Core/TyCo/Rep.hs +22/−54
• compiler/GHC/Core/TyCo/Rep.hs-boot +2/−0
• compiler/GHC/Core/TyCo/Subst.hs +1/−1
• compiler/GHC/Core/TyCon.hs +180/−129
• compiler/GHC/Core/Type.hs +41/−5
• compiler/GHC/Core/Type.hs-boot +2/−0
• compiler/GHC/Core/Unfold.hs +163/−33
• compiler/GHC/Core/Unfold.hs-boot +2/−0
• compiler/GHC/Core/Unify.hs +57/−12
• compiler/GHC/Core/Utils.hs +31/−4
• compiler/GHC/CoreToIface.hs +1/−0
• compiler/GHC/Data/FastMutInt.hs +2/−2
• compiler/GHC/Data/FastString.hs +7/−0
• compiler/GHC/Data/IOEnv.hs +30/−3
• compiler/GHC/Data/Stream.hs +86/−77
• compiler/GHC/Data/StringBuffer.hs +18/−12
• compiler/GHC/Driver/Env.hs +1/−2
• compiler/GHC/Driver/Env/Types.hs +12/−0
• compiler/GHC/Driver/Errors.hs +20/−19
• compiler/GHC/Driver/Flags.hs +1/−0
• compiler/GHC/Driver/Hooks.hs +26/−27
• compiler/GHC/Driver/Hooks.hs-boot +6/−0
• compiler/GHC/Driver/Monad.hs +59/−3
• compiler/GHC/Driver/Pipeline/Monad.hs +4/−0
• compiler/GHC/Driver/Session.hs +31/−170
• compiler/GHC/Hs/Expr.hs +177/−13
• compiler/GHC/Hs/Utils.hs +5/−1
• compiler/GHC/Iface/Type.hs +12/−4
• compiler/GHC/Parser/Errors.hs +4/−4
• compiler/GHC/Parser/Errors/Ppr.hs +8/−8
• compiler/GHC/Parser/Header.hs +4/−4
• compiler/GHC/Parser/PostProcess.hs +1/−1
• compiler/GHC/Parser/PostProcess/Haddock.hs +2/−2
• compiler/GHC/SysTools/FileCleanup.hs +34/−33
• compiler/GHC/Tc/Types.hs +16/−5
• compiler/GHC/Tc/Types/Origin.hs +2/−2
• compiler/GHC/Tc/Utils/TcType.hs +39/−15
• compiler/GHC/Types/Avail.hs +18/−18
• compiler/GHC/Types/Basic.hs +7/−2
• compiler/GHC/Types/Demand.hs +25/−1
• compiler/GHC/Types/Error.hs +70/−74
• compiler/GHC/Types/FieldLabel.hs +80/−19
• compiler/GHC/Types/Id.hs +5/−6
• compiler/GHC/Types/Id/Make.hs +80/−7
• compiler/GHC/Types/Literal.hs +7/−15
• compiler/GHC/Types/Name.hs +51/−9
• compiler/GHC/Types/Name/Occurrence.hs +1/−1
• compiler/GHC/Types/Name/Reader.hs +31/−8
• compiler/GHC/Types/SourceError.hs +1/−1
• compiler/GHC/Types/SourceText.hs +104/−27
• compiler/GHC/Types/SrcLoc.hs +26/−5
• compiler/GHC/Types/Unique/Supply.hs +0/−13
• compiler/GHC/Types/Var.hs +10/−4
• compiler/GHC/Unit/State.hs +12/−10
• compiler/GHC/Utils/Binary.hs +19/−7
• compiler/GHC/Utils/Binary/Typeable.hs +9/−1
• compiler/GHC/Utils/Error.hs +87/−336
• compiler/GHC/Utils/Error.hs-boot +0/−31
• compiler/GHC/Utils/Logger.hs +473/−0
• compiler/GHC/Utils/Misc.hs +104/−8
• compiler/GHC/Utils/Monad.hs +11/−0
• compiler/Language/Haskell/Syntax/Decls.hs +1/−1
• compiler/Language/Haskell/Syntax/Expr.hs +5/−152
• compiler/Language/Haskell/Syntax/Type.hs +2/−0
• ghc-lib-parser.cabal +5/−5
• ghc-lib/stage0/compiler/build/GHC/Parser.hs +9694/−9654
• ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs +16/−14
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +1/−0
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +4/−3
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +1/−0
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +1/−0
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +1/−0
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1283/−1282
• ghc-lib/stage0/lib/DerivedConstants.h +1/−1
• ghc-lib/stage0/lib/ghcversion.h +0/−21
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +1/−1
• libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +4/−4
• libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs +4/−4
• libraries/ghci/GHCi/Message.hs +1/−1
• libraries/template-haskell/Language/Haskell/TH/Lib.hs +1/−1
• libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +3/−0
• libraries/template-haskell/Language/Haskell/TH/Ppr.hs +23/−22
• libraries/template-haskell/Language/Haskell/TH/Syntax.hs +1/−0

@@ -247,12 +247,13 @@         typeLitSortTyConName,         typeLitSymbolDataConName,         typeLitNatDataConName,+        typeLitCharDataConName,         typeRepIdName,         mkTrTypeName,         mkTrConName,         mkTrAppName,         mkTrFunName,-        typeSymbolTypeRepName, typeNatTypeRepName,+        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,         trGhcPrimModuleName,          -- KindReps for common cases@@ -265,6 +266,7 @@          -- Numeric stuff         negateName, minusName, geName, eqName,+        mkRationalBase2Name, mkRationalBase10Name,          -- Conversion functions         rationalTyConName,@@ -439,10 +441,10 @@         randomClassName, randomGenClassName, monadPlusClassName,          -- Type-level naturals-        knownNatClassName, knownSymbolClassName,+        knownNatClassName, knownSymbolClassName, knownCharClassName,          -- Overloaded labels-        isLabelClassName,+        fromLabelClassOpName,          -- Implicit Parameters         ipClassName,@@ -1339,7 +1341,7 @@ rationalTyConName, ratioTyConName, ratioDataConName, realClassName,     integralClassName, realFracClassName, fractionalClassName,     fromRationalName, toIntegerName, toRationalName, fromIntegralName,-    realToFracName :: Name+    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey@@ -1352,7 +1354,8 @@ toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey-+mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey@@ -1405,10 +1408,12 @@ typeLitSortTyConName   , typeLitSymbolDataConName   , typeLitNatDataConName+  , typeLitCharDataConName   :: Name typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey+typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey  -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName@@ -1422,6 +1427,7 @@   , typeRepIdName   , typeNatTypeRepName   , typeSymbolTypeRepName+  , typeCharTypeRepName   , trGhcPrimModuleName   :: Name typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey@@ -1435,6 +1441,7 @@ mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) -- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey@@ -1617,11 +1624,13 @@ knownNatClassName     = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey knownSymbolClassName :: Name knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownCharClassName :: Name+knownCharClassName  = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey  -- Overloaded labels-isLabelClassName :: Name-isLabelClassName- = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey+fromLabelClassOpName :: Name+fromLabelClassOpName+ = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey  -- Implicit Parameters ipClassName :: Name@@ -1692,13 +1701,18 @@ All these are original names; hence mkOrig -} +{-# INLINE varQual #-}+{-# INLINE tcQual #-}+{-# INLINE clsQual #-}+{-# INLINE dcQual #-} varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name-varQual  = mk_known_key_name varName-tcQual   = mk_known_key_name tcName-clsQual  = mk_known_key_name clsName-dcQual   = mk_known_key_name dataName+varQual  modu str unique = mk_known_key_name varName modu str unique+tcQual   modu str unique = mk_known_key_name tcName modu str unique+clsQual  modu str unique = mk_known_key_name clsName modu str unique+dcQual   modu str unique = mk_known_key_name dataName modu str unique  mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+{-# INLINE mk_known_key_name #-} mk_known_key_name space modu str unique   = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan @@ -1773,23 +1787,23 @@ knownSymbolClassNameKey :: Unique knownSymbolClassNameKey = mkPreludeClassUnique 43 -ghciIoClassKey :: Unique-ghciIoClassKey = mkPreludeClassUnique 44+knownCharClassNameKey :: Unique+knownCharClassNameKey = mkPreludeClassUnique 44 -isLabelClassNameKey :: Unique-isLabelClassNameKey = mkPreludeClassUnique 45+ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 45  semigroupClassKey, monoidClassKey :: Unique-semigroupClassKey = mkPreludeClassUnique 46-monoidClassKey    = mkPreludeClassUnique 47+semigroupClassKey = mkPreludeClassUnique 47+monoidClassKey    = mkPreludeClassUnique 48  -- Implicit Parameters ipClassKey :: Unique-ipClassKey = mkPreludeClassUnique 48+ipClassKey = mkPreludeClassUnique 49  -- Overloaded record fields hasFieldClassNameKey :: Unique-hasFieldClassNameKey = mkPreludeClassUnique 49+hasFieldClassNameKey = mkPreludeClassUnique 50   ---------------- Template Haskell -------------------@@ -1973,81 +1987,88 @@ uWordTyConKey   = mkPreludeTyConUnique 163  -- Type-level naturals-typeSymbolKindConNameKey,+typeSymbolKindConNameKey, typeCharKindConNameKey,   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,   typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey-  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey+  , typeLeqCharTyFamNameKey   , typeNatDivTyFamNameKey   , typeNatModTyFamNameKey   , typeNatLogTyFamNameKey+  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey   :: Unique typeSymbolKindConNameKey  = mkPreludeTyConUnique 165-typeNatAddTyFamNameKey    = mkPreludeTyConUnique 166-typeNatMulTyFamNameKey    = mkPreludeTyConUnique 167-typeNatExpTyFamNameKey    = mkPreludeTyConUnique 168-typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 169-typeNatSubTyFamNameKey    = mkPreludeTyConUnique 170-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171-typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 172-typeNatDivTyFamNameKey  = mkPreludeTyConUnique 173-typeNatModTyFamNameKey  = mkPreludeTyConUnique 174-typeNatLogTyFamNameKey  = mkPreludeTyConUnique 175+typeCharKindConNameKey    = mkPreludeTyConUnique 166+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 167+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 168+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 169+typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 170+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 171+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 172+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 173+typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 174+typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 175+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 176+typeNatModTyFamNameKey  = mkPreludeTyConUnique 177+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 178+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 179+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 180  -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 176+errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 181    ntTyConKey:: Unique-ntTyConKey = mkPreludeTyConUnique 177+ntTyConKey = mkPreludeTyConUnique 182 coercibleTyConKey :: Unique-coercibleTyConKey = mkPreludeTyConUnique 178+coercibleTyConKey = mkPreludeTyConUnique 183  proxyPrimTyConKey :: Unique-proxyPrimTyConKey = mkPreludeTyConUnique 179+proxyPrimTyConKey = mkPreludeTyConUnique 184  specTyConKey :: Unique-specTyConKey = mkPreludeTyConUnique 180+specTyConKey = mkPreludeTyConUnique 185  anyTyConKey :: Unique-anyTyConKey = mkPreludeTyConUnique 181+anyTyConKey = mkPreludeTyConUnique 186 -smallArrayPrimTyConKey        = mkPreludeTyConUnique  182-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  183+smallArrayPrimTyConKey        = mkPreludeTyConUnique  187+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188  staticPtrTyConKey  :: Unique-staticPtrTyConKey  = mkPreludeTyConUnique 184+staticPtrTyConKey  = mkPreludeTyConUnique 189  staticPtrInfoTyConKey :: Unique-staticPtrInfoTyConKey = mkPreludeTyConUnique 185+staticPtrInfoTyConKey = mkPreludeTyConUnique 190  callStackTyConKey :: Unique-callStackTyConKey = mkPreludeTyConUnique 186+callStackTyConKey = mkPreludeTyConUnique 191  -- Typeables typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique-typeRepTyConKey       = mkPreludeTyConUnique 187-someTypeRepTyConKey   = mkPreludeTyConUnique 188-someTypeRepDataConKey = mkPreludeTyConUnique 189+typeRepTyConKey       = mkPreludeTyConUnique 192+someTypeRepTyConKey   = mkPreludeTyConUnique 193+someTypeRepDataConKey = mkPreludeTyConUnique 194   typeSymbolAppendFamNameKey :: Unique-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195  -- Unsafe equality unsafeEqualityTyConKey :: Unique-unsafeEqualityTyConKey = mkPreludeTyConUnique 191+unsafeEqualityTyConKey = mkPreludeTyConUnique 196  -- Linear types multiplicityTyConKey :: Unique-multiplicityTyConKey = mkPreludeTyConUnique 192+multiplicityTyConKey = mkPreludeTyConUnique 197  unrestrictedFunTyConKey :: Unique-unrestrictedFunTyConKey = mkPreludeTyConUnique 193+unrestrictedFunTyConKey = mkPreludeTyConUnique 198  multMulTyConKey :: Unique-multMulTyConKey = mkPreludeTyConUnique 194+multMulTyConKey = mkPreludeTyConUnique 199  ---------------- Template Haskell ------------------- --      GHC.Builtin.Names.TH: USES TyConUniques 200-299@@ -2212,19 +2233,20 @@ kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 -typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique+typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique typeLitSymbolDataConKey   = mkPreludeDataConUnique 112 typeLitNatDataConKey      = mkPreludeDataConUnique 113+typeLitCharDataConKey     = mkPreludeDataConUnique 114  -- Unsafe equality unsafeReflDataConKey :: Unique-unsafeReflDataConKey      = mkPreludeDataConUnique 114+unsafeReflDataConKey      = mkPreludeDataConUnique 115  -- Multiplicity  oneDataConKey, manyDataConKey :: Unique-oneDataConKey = mkPreludeDataConUnique 115-manyDataConKey = mkPreludeDataConUnique 116+oneDataConKey = mkPreludeDataConUnique 116+manyDataConKey = mkPreludeDataConUnique 117  -- ghc-bignum integerISDataConKey, integerINDataConKey, integerIPDataConKey,@@ -2314,6 +2336,9 @@ otherwiseIdKey                = mkPreludeMiscIdUnique 43 assertIdKey                   = mkPreludeMiscIdUnique 44 +leftSectionKey, rightSectionKey :: Unique+leftSectionKey                = mkPreludeMiscIdUnique 45+rightSectionKey               = mkPreludeMiscIdUnique 46  rootMainKey, runMainKey :: Unique rootMainKey                   = mkPreludeMiscIdUnique 101@@ -2395,6 +2420,10 @@ failMClassOpKey :: Unique failMClassOpKey = mkPreludeMiscIdUnique 176 +-- fromLabel+fromLabelClassOpKey :: Unique+fromLabelClassOpKey = mkPreludeMiscIdUnique 177+ -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,     loopAIdKey :: Unique@@ -2451,6 +2480,7 @@   , mkTrFunKey   , typeNatTypeRepKey   , typeSymbolTypeRepKey+  , typeCharTypeRepKey   , typeRepIdKey   :: Unique mkTyConKey            = mkPreludeMiscIdUnique 503@@ -2459,8 +2489,9 @@ mkTrAppKey            = mkPreludeMiscIdUnique 506 typeNatTypeRepKey     = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508-typeRepIdKey          = mkPreludeMiscIdUnique 509-mkTrFunKey            = mkPreludeMiscIdUnique 510+typeCharTypeRepKey    = mkPreludeMiscIdUnique 509+typeRepIdKey          = mkPreludeMiscIdUnique 510+mkTrFunKey            = mkPreludeMiscIdUnique 511  -- Representations for primitive types trTYPEKey@@ -2468,10 +2499,10 @@   , trRuntimeRepKey   , tr'PtrRepLiftedKey   :: Unique-trTYPEKey              = mkPreludeMiscIdUnique 511-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512-trRuntimeRepKey        = mkPreludeMiscIdUnique 513-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 514+trTYPEKey              = mkPreludeMiscIdUnique 512+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513+trRuntimeRepKey        = mkPreludeMiscIdUnique 514+tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 515  -- KindReps for common cases starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique@@ -2686,6 +2717,15 @@ naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684  bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690++------------------------------------------------------+-- ghci optimization for big rationals 700-749 uniques+------------------------------------------------------++-- Creating rationals at runtime.+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique+mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique  {- ************************************************************************

@@ -634,7 +634,7 @@  STG requires that primop applications be saturated. This makes code generation significantly simpler since otherwise we would need to define a calling-convention for curried applications that can accomodate levity polymorphism.+convention for curried applications that can accommodate levity polymorphism.  To ensure saturation, CorePrep eta expands expand all primop applications as described in Note [Eta expansion of hasNoBinding things in CorePrep] in

@@ -68,13 +68,14 @@         maybeTyCon, maybeTyConName,         nothingDataCon, nothingDataConName, promotedNothingDataCon,         justDataCon, justDataConName, promotedJustDataCon,+        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,          -- * Tuples         mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,         tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,         promotedTupleDataCon,         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,-        pairTyCon,+        pairTyCon, mkPromotedPairTy, isPromotedPairType,         unboxedUnitTy,         unboxedUnitTyCon, unboxedUnitDataCon,         unboxedTupleKind, unboxedSumKind,@@ -691,9 +692,9 @@  -- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. liftedTypeKind, typeToTypeKind, constraintKind :: Kind-liftedTypeKind   = TyCoRep.TyConApp liftedTypeKindTyCon []+liftedTypeKind   = mkTyConTy liftedTypeKindTyCon typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind-constraintKind   = mkTyConApp constraintKindTyCon []+constraintKind   = mkTyConTy constraintKindTyCon  {- ************************************************************************@@ -1005,6 +1006,16 @@ tupleDataConName :: Boxity -> Arity -> Name tupleDataConName sort i = dataConName (tupleDataCon sort i) +mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]++isPromotedPairType :: Type -> Maybe (Type, Type)+isPromotedPairType t+  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t+  , tc == promotedTupleDataCon Boxed 2+  = Just (x, y)+  | otherwise = Nothing+ boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]] unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]@@ -1791,6 +1802,20 @@ justDataCon :: DataCon justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon +mkPromotedMaybeTy :: Kind -> Maybe Type -> Type+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]+mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]++mkMaybeTy :: Type -> Kind+mkMaybeTy t = mkTyConApp maybeTyCon [t]++isPromotedMaybeTy :: Type -> Maybe (Maybe Type)+isPromotedMaybeTy t+  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x+  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing+  | otherwise = Nothing++ {- ** ********************************************************************* *                                                                      *@@ -1933,8 +1958,6 @@        | otherwise       = pprPanic "extractPromotedList" (ppr tys)--  --------------------------------------- -- ghc-bignum

@@ -9,6 +9,7 @@  listTyCon :: TyCon typeSymbolKind :: Type+charTy :: Type mkBoxedTupleTy :: [Type] -> Type  coercibleTyCon, heqTyCon :: TyCon

@@ -23,11 +23,14 @@         alphaTys, alphaTy, betaTy, gammaTy, deltaTy,         alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep,         alphaTysUnliftedRep, alphaTyUnliftedRep,-        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,-        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,+        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,+        runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty, -        multiplicityTyVar,+        openAlphaTyVar, openBetaTyVar, openGammaTyVar,+        openAlphaTy, openBetaTy, openGammaTy, +        multiplicityTyVar1, multiplicityTyVar2,+         -- Kind constructors...         tYPETyCon, tYPETyConName, @@ -126,6 +129,7 @@ import GHC.Utils.Panic 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 )  import Data.Char @@ -247,7 +251,13 @@ stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon++#if MIN_VERSION_ghc_prim(0, 7, 0)+bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon+#else bcoPrimTyConName              = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon+#endif+ weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon @@ -374,27 +384,32 @@ alphaTyUnliftedRep :: Type (alphaTyUnliftedRep:_) = alphaTysUnliftedRep -runtimeRep1TyVar, runtimeRep2TyVar :: TyVar-(runtimeRep1TyVar : runtimeRep2TyVar : _)+runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar+(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _)   = drop 16 (mkTemplateTyVars (repeat runtimeRepTy))  -- selects 'q','r' -runtimeRep1Ty, runtimeRep2Ty :: Type+runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar+runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar -openAlphaTyVar, openBetaTyVar :: TyVar+openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar -- alpha :: TYPE r1 -- beta  :: TYPE r2-[openAlphaTyVar,openBetaTyVar]-  = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]+-- gamma :: TYPE r3+[openAlphaTyVar,openBetaTyVar,openGammaTyVar]+  = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty] -openAlphaTy, openBetaTy :: Type+openAlphaTy, openBetaTy, openGammaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy  = mkTyVarTy openBetaTyVar+openGammaTy = mkTyVarTy openGammaTyVar -multiplicityTyVar :: TyVar-multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13  -- selects 'n'+multiplicityTyVar1, multiplicityTyVar2  :: TyVar+(multiplicityTyVar1 : multiplicityTyVar2 : _)+   = drop 13 (mkTemplateTyVars (repeat multiplicityTy))  -- selects 'n', 'm' + {- ************************************************************************ *                                                                      *@@ -431,7 +446,7 @@ funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm   where     -- See also unrestrictedFunTyCon-    tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar+    tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1                , mkNamedTyConBinder Inferred runtimeRep1TyVar                , mkNamedTyConBinder Inferred runtimeRep2TyVar ]                ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty@@ -1097,7 +1112,13 @@ bcoPrimTy    :: Type bcoPrimTy    = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon++#if MIN_VERSION_ghc_prim(0, 7, 0)+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep+#else bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep+#endif+  {- ************************************************************************

@@ -1378,7 +1378,7 @@ -- Note that these labels are *not* referred to by code. They are strictly for -- diagnostics purposes. ----- To avoid confusion, it is desireable to add a module-qualifier to the+-- To avoid confusion, it is desirable to add a module-qualifier to the -- symbol name. However, the Name type's Internal constructor doesn't carry -- knowledge of the current Module. Consequently, we have to pass this around -- explicitly.

@@ -275,7 +275,7 @@ -----------------------------------------------------------------------------  data LocalReg-  = LocalReg {-# UNPACK #-} !Unique CmmType+  = LocalReg {-# UNPACK #-} !Unique !CmmType     -- ^ Parameters:     --   1. Identifier     --   2. Type

@@ -50,7 +50,7 @@   -- and is used extensively in pattern-matching  data CmmType    -- The important one!-  = CmmType CmmCat Width+  = CmmType CmmCat !Width  data CmmCat                -- "Category" (not exported)    = GcPtrCat              -- GC pointer

@@ -1400,6 +1400,7 @@    { 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

@@ -104,8 +104,9 @@             , fi_fam   :: Name          -- Family name                  -- Used for "rough matching"; same idea as for class instances-                -- See Note [Rough-match field] in GHC.Core.InstEnv-            , fi_tcs   :: [Maybe Name]  -- Top of type args+                -- See Note [Rough matching in class and family instances]+                -- in GHC.Core.Unify+            , fi_tcs   :: [RoughMatchTc]  -- Top of type args                 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys              -- Used for "proper matching"; ditto@@ -264,7 +265,7 @@ -- interface file.  In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name               -- Name of the family-                  -> [Maybe Name]       -- Rough match info+                  -> [RoughMatchTc]     -- Rough match info                   -> CoAxiom Unbranched -- Axiom introduced                   -> FamInst            -- Resulting family instance mkImportedFamInst fam mb_tcs axiom

@@ -49,11 +49,10 @@ import GHC.Types.Unique.DFM import GHC.Types.Id import Data.Data        ( Data )-import Data.Maybe       ( isJust, isNothing )+import Data.Maybe       ( isJust )  import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Utils.Error import GHC.Utils.Panic  {-@@ -71,8 +70,8 @@   = ClsInst {   -- Used for "rough matching"; see                 -- Note [ClsInst laziness and the rough-match fields]                 -- INVARIANT: is_tcs = roughMatchTcs is_tys-               is_cls_nm :: Name        -- ^ Class name-             , is_tcs  :: [Maybe Name]  -- ^ Top of type args+               is_cls_nm :: Name          -- ^ Class name+             , is_tcs  :: [RoughMatchTc]  -- ^ Top of type args                 -- | @is_dfun_name = idName . is_dfun@.                --@@ -108,10 +107,10 @@     stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`     mconcat (map cmp (zip (is_tcs x) (is_tcs y)))   where-    cmp (Nothing, Nothing) = EQ-    cmp (Nothing, Just _) = LT-    cmp (Just _, Nothing) = GT-    cmp (Just x, Just y) = stableNameCmp x y+    cmp (OtherTc,   OtherTc)   = EQ+    cmp (OtherTc,   KnownTc _) = LT+    cmp (KnownTc _, OtherTc)   = GT+    cmp (KnownTc x, KnownTc y) = stableNameCmp x y  isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))@@ -136,25 +135,16 @@   pull in interfaces that it refers to. See Note [Proper-match fields].  * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and-  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking+  is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking   inside the DFunId. The rough-match fields allow us to say "definitely does not-  match", based only on Names.+  match", based only on Names.  See GHC.Core.Unify+  Note [Rough matching in class and family instances]    This laziness is very important; see #12367. Try hard to avoid pulling on   the structured fields unless you really need the instance.  * Another place to watch is InstEnv.instIsVisible, which needs the module to   which the ClsInst belongs. We can get this from is_dfun_name.--* In is_tcs,-    Nothing  means that this type arg is a type variable--    (Just n) means that this type arg is a-                TyConApp with a type constructor of n.-                This is always a real tycon, never a synonym!-                (Two different synonyms might match, but two-                different real tycons can't.)-                NB: newtypes are not transparent, though! -}  {-@@ -207,10 +197,9 @@ updateClsInstDFun tidy_dfun ispec   = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [Maybe Name]+instanceRoughTcs :: ClsInst -> [RoughMatchTc] instanceRoughTcs = is_tcs - instance NamedThing ClsInst where    getName ispec = getName (is_dfun ispec) @@ -301,12 +290,12 @@      choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: Name         -- ^ the name of the class-                   -> [Maybe Name] -- ^ the types which the class was applied to-                   -> Name         -- ^ the 'Name' of the dictionary binding-                   -> DFunId       -- ^ the 'Id' of the dictionary.-                   -> OverlapFlag  -- ^ may this instance overlap?-                   -> IsOrphan     -- ^ is this instance an orphan?+mkImportedInstance :: Name           -- ^ the name of the class+                   -> [RoughMatchTc] -- ^ the types which the class was applied to+                   -> Name           -- ^ the 'Name' of the dictionary binding+                   -> DFunId         -- ^ the 'Id' of the dictionary.+                   -> OverlapFlag    -- ^ may this instance overlap?+                   -> IsOrphan       -- ^ is this instance an orphan?                    -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file@@ -810,7 +799,7 @@ -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs                     -> Class -> [Type]-                    -> Either MsgDoc (ClsInst, [Type])+                    -> Either SDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys   = case lookupInstEnv False instEnv cls tys of       ([(inst, inst_tys)], _, _)@@ -843,7 +832,6 @@   = lookup ie   where     rough_tcs  = roughMatchTcs tys-    all_tvs    = all isNothing rough_tcs      --------------     lookup env = case lookupUDFM env cls of@@ -872,7 +860,7 @@        | otherwise       = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,-                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$+                 (ppr cls <+> ppr tys) $$                  (ppr tpl_tvs <+> ppr tpl_tys)                 )                 -- Unification will break badly if the variables overlap

@@ -65,8 +65,10 @@ import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Types.Basic-import GHC.Utils.Error hiding ( dumpIfSet )+import GHC.Utils.Error import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger (Logger, putLogMsg, putDumpMsg, DumpFormat (..), getLogger)+import qualified GHC.Utils.Logger as Logger import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable@@ -212,14 +214,14 @@ * 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` becuase it's already in scope.  Fine,+  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 subsitution in types/coercions only, when+  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@@ -288,21 +290,23 @@           -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules-  = do { dumpPassResult dflags print_unqual mb_flag+  = do { dumpPassResult logger dflags print_unqual mb_flag                         (ppr pass) (pprPassDetails pass) binds rules        ; lintPassResult hsc_env pass binds }   where+    logger  = hsc_logger hsc_env     dflags  = hsc_dflags hsc_env     mb_flag = case coreDumpFlag pass of                 Just flag | dopt flag dflags                    -> Just flag                           | dopt Opt_D_verbose_core2core dflags -> Just flag                 _ -> Nothing -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()-dumpIfSet dflags dump_me pass extra_info doc-  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc+dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()+dumpIfSet logger dflags dump_me pass extra_info doc+  = Logger.dumpIfSet logger dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc -dumpPassResult :: DynFlags+dumpPassResult :: Logger+               -> DynFlags                -> PrintUnqualified                -> Maybe DumpFlag        -- Just df => show details in a file whose                                         --            name is specified by df@@ -310,16 +314,16 @@                -> SDoc                  -- Extra info to appear after header                -> CoreProgram -> [CoreRule]                -> IO ()-dumpPassResult dflags unqual mb_flag hdr extra_info binds rules+dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules   = do { forM_ mb_flag $ \flag -> do            let sty = mkDumpStyle unqual-           dumpAction dflags sty (dumpOptionsFromFlag flag)+           putDumpMsg logger dflags sty flag               (showSDoc dflags 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 dflags 2 size_doc+       ; Err.debugTraceMsg logger dflags 2 size_doc        }    where@@ -375,35 +379,37 @@   = return ()   | otherwise   = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds-       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)-       ; displayLintResults dflags (showLintWarnings pass) (ppr pass)+       ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass)+       ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass)                             (pprCoreBindings binds) warns_and_errs }   where     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env -displayLintResults :: DynFlags+displayLintResults :: Logger+                   -> DynFlags                    -> 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 dflags display_warnings pp_what pp_pgm (warns, errs)+displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs)   | not (isEmptyBag errs)-  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan+  = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan            $ withPprStyle defaultDumpStyle            (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs                  , text "*** Offending Program ***"                  , pp_pgm                  , text "*** End of Offense ***" ])-       ; Err.ghcExit dflags 1 }+       ; Err.ghcExit logger dflags 1 }    | not (isEmptyBag warns)   , not (hasNoDebugOutput dflags)   , display_warnings   -- If the Core linter encounters an error, output to stderr instead of   -- stdout (#13342)-  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan+  = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan       $ withPprStyle defaultDumpStyle         (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -426,11 +432,12 @@   | not (gopt Opt_DoCoreLinting dflags)   = return ()   | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr-  = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err)+  = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err)   | otherwise   = return ()   where     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env  interactiveInScope :: HscEnv -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving'@@ -541,7 +548,7 @@               -> SrcLoc               -> VarSet             -- Treat these as in scope               -> CoreExpr-              -> Maybe (Bag MsgDoc) -- Nothing => OK+              -> Maybe (Bag SDoc) -- Nothing => OK  lintUnfolding is_compulsory dflags locn var_set expr   | isEmptyBag errs = Nothing@@ -559,7 +566,7 @@ lintExpr :: DynFlags          -> [Var]               -- Treat these as in scope          -> CoreExpr-         -> Maybe (Bag MsgDoc)  -- Nothing => OK+         -> Maybe (Bag SDoc)  -- Nothing => OK  lintExpr dflags vars expr   | isEmptyBag errs = Nothing@@ -1767,6 +1774,7 @@   | 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)@@ -2313,12 +2321,13 @@ ************************************************************************ -} -lintAxioms :: DynFlags+lintAxioms :: Logger+           -> DynFlags            -> SDoc -- ^ The source of the linted axioms            -> [CoAxiom Branched]            -> IO ()-lintAxioms dflags what axioms =-  displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $+lintAxioms logger dflags what axioms =+  displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $   initL dflags (defaultLintFlags dflags) [] $   do { mapM_ lint_axiom axioms      ; let axiom_groups = groupWith coAxiomTyCon axioms@@ -2551,7 +2560,7 @@             (Maybe a, WarnsAndErrs) } -- Result and messages (if any)    deriving (Functor) -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)+type WarnsAndErrs = (Bag SDoc, Bag SDoc)  {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2710,31 +2719,31 @@ getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) -checkL :: Bool -> MsgDoc -> LintM ()+checkL :: Bool -> SDoc -> LintM () checkL True  _   = return () checkL False msg = failWithL msg  -- like checkL, but relevant to type checking-lintL :: Bool -> MsgDoc -> LintM ()+lintL :: Bool -> SDoc -> LintM () lintL = checkL -checkWarnL :: Bool -> MsgDoc -> LintM ()+checkWarnL :: Bool -> SDoc -> LintM () checkWarnL True   _  = return () checkWarnL False msg = addWarnL msg -failWithL :: MsgDoc -> LintM a+failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) ->                 (Nothing, (warns, addMsg True env errs msg)) -addErrL :: MsgDoc -> LintM ()+addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) ->               (Just (), (warns, addMsg True env errs msg)) -addWarnL :: MsgDoc -> LintM ()+addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) ->               (Just (), (addMsg False env warns msg, errs)) -addMsg :: Bool -> LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg   = ASSERT2( notNull loc_msgs, msg )     msgs `snocBag` mk_msg msg@@ -2862,7 +2871,7 @@          Nothing -> unitUE id One          Just id_ue -> id_ue -ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM ()+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@@ -2996,36 +3005,36 @@ ------------------------------------------------------ --      Messages for case expressions -mkDefaultArgsMsg :: [Var] -> MsgDoc+mkDefaultArgsMsg :: [Var] -> SDoc mkDefaultArgsMsg args   = hang (text "DEFAULT case with binders")          4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc+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 -> MsgDoc+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 -> MsgDoc+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 -> MsgDoc+nonExhaustiveAltsMsg :: CoreExpr -> SDoc nonExhaustiveAltsMsg e   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> MsgDoc+mkBadConMsg :: TyCon -> DataCon -> SDoc mkBadConMsg tycon datacon   = vcat [         text "In a case alternative, data constructor isn't in scrutinee type:",@@ -3033,7 +3042,7 @@         text "Data con:" <+> ppr datacon     ] -mkBadPatMsg :: Type -> Type -> MsgDoc+mkBadPatMsg :: Type -> Type -> SDoc mkBadPatMsg con_result_ty scrut_ty   = vcat [         text "In a case alternative, pattern result type doesn't match scrutinee type:",@@ -3041,17 +3050,17 @@         text "Scrutinee type:" <+> ppr scrut_ty     ] -integerScrutinisedMsg :: MsgDoc+integerScrutinisedMsg :: SDoc integerScrutinisedMsg   = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc+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 -> MsgDoc+mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc mkNewTyDataConAltMsg scrut_ty alt   = vcat [ text "Data alternative for newtype datacon",            text "Scrutinee type:" <+> ppr scrut_ty,@@ -3061,21 +3070,21 @@ ------------------------------------------------------ --      Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+mkAppMsg :: Type -> Type -> CoreExpr -> SDoc mkAppMsg fun_ty arg_ty arg   = vcat [text "Argument value doesn't match argument type:",               hang (text "Fun type:") 4 (ppr fun_ty),               hang (text "Arg type:") 4 (ppr arg_ty),               hang (text "Arg:") 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+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 -> MsgDoc+mkLetErr :: TyVar -> CoreExpr -> SDoc mkLetErr bndr rhs   = vcat [text "Bad `let' binding:",           hang (text "Variable:")@@ -3083,7 +3092,7 @@           hang (text "Rhs:")                  4 (ppr rhs)] -mkTyAppMsg :: Type -> Type -> MsgDoc+mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty   = vcat [text "Illegal type application:",               hang (text "Exp type:")@@ -3091,10 +3100,10 @@               hang (text "Arg type:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -emptyRec :: CoreExpr -> MsgDoc+emptyRec :: CoreExpr -> SDoc emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc+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,@@ -3102,29 +3111,29 @@      hsep [text "Binder's type:", ppr (idType binder)],      hsep [text "Rhs type:", ppr ty]] -mkLetAppMsg :: CoreExpr -> MsgDoc+mkLetAppMsg :: CoreExpr -> SDoc mkLetAppMsg e   = hang (text "This argument does not satisfy the let/app invariant:")        2 (ppr e) -badBndrTyMsg :: Id -> SDoc -> MsgDoc+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 -> MsgDoc+mkNonTopExportedMsg :: Id -> SDoc mkNonTopExportedMsg binder   = hsep [text "Non-top-level binder is marked as exported:", ppr binder] -mkNonTopExternalNameMsg :: Id -> MsgDoc+mkNonTopExternalNameMsg :: Id -> SDoc mkNonTopExternalNameMsg binder   = hsep [text "Non-top-level binder has an external name:", ppr binder] -mkTopNonLitStrMsg :: Id -> MsgDoc+mkTopNonLitStrMsg :: Id -> SDoc mkTopNonLitStrMsg binder   = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] -mkKindErrMsg :: TyVar -> Type -> MsgDoc+mkKindErrMsg :: TyVar -> Type -> SDoc mkKindErrMsg tyvar arg_ty   = vcat [text "Kinds don't match in type application:",           hang (text "Type variable:")@@ -3132,10 +3141,10 @@           hang (text "Arg type:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc+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@@ -3143,7 +3152,7 @@             -> String -- ^ What sort of coercion is being used                       --   (\"type\" or \"kind\").             -> SDoc   -- ^ The thing being casted.-            -> Coercion -> Type -> Type -> MsgDoc+            -> 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,@@ -3234,16 +3243,16 @@          , text "Join arity:" <+> ppr join_arity          , text "Rule:" <+> ppr rule ] -pprLeftOrRight :: LeftOrRight -> MsgDoc+pprLeftOrRight :: LeftOrRight -> SDoc pprLeftOrRight CLeft  = text "left" pprLeftOrRight CRight = text "right" -dupVars :: [NonEmpty Var] -> MsgDoc+dupVars :: [NonEmpty Var] -> SDoc dupVars vars   = hang (text "Duplicate variables brought into scope")        2 (ppr (map toList vars)) -dupExtVars :: [NonEmpty Name] -> MsgDoc+dupExtVars :: [NonEmpty Name] -> SDoc dupExtVars vars   = hang (text "Duplicate top-level variables with the same qualified name")        2 (ppr (map toList vars))@@ -3264,16 +3273,17 @@ lintAnnots pname pass guts = do   -- Run the pass as we normally would   dflags <- getDynFlags+  logger <- getLogger   when (gopt Opt_DoAnnotationLinting dflags) $-    liftIO $ Err.showPass dflags "Annotation linting - first run"+    liftIO $ Err.showPass logger dflags "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 dflags "Annotation linting - second run"+    liftIO $ Err.showPass logger dflags "Annotation linting - second run"     nguts' <- withoutAnnots pass guts     -- Finally compare the resulting bindings-    liftIO $ Err.showPass dflags "Annotation linting - comparison"+    liftIO $ Err.showPass logger dflags "Annotation linting - comparison"     let binds = flattenBinds $ mg_binds nguts         binds' = flattenBinds $ mg_binds nguts'         (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'

@@ -769,7 +769,6 @@ raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name  recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID-absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_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@@ -859,6 +858,13 @@       (fsLit "absentSumFieldError")       absentSumFieldErrorIdKey       aBSENT_SUM_FIELD_ERROR_ID++absentErrorName+   = mkWiredInIdName+      gHC_PRIM_PANIC+      (fsLit "absentError")+      absentErrorIdKey+      aBSENT_ERROR_ID  raiseOverflowName    = mkWiredInIdName

@@ -9,7 +9,7 @@  module GHC.Core.Map.Type (      -- * Re-export generic interface-   TrieMap(..),+   TrieMap(..), XT,       -- * Maps over 'Type's    TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,@@ -165,7 +165,7 @@   -- First check for TyConApps that need to be expanded to   -- AppTy chains.   | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty-  = Just $ foldl' AppTy (TyConApp tc []) tys+  = Just $ foldl' AppTy (mkTyConTy tc) tys    -- Then resolve any remaining nullary synonyms.   | Just ty' <- tcView ty = Just ty'@@ -307,6 +307,7 @@ ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a                       , tlm_string :: UniqFM  FastString a+                      , tlm_char   :: Map.Map Char a                       }  instance TrieMap TyLitMap where@@ -319,31 +320,34 @@    filterTM = filterTyLit  emptyTyLitMap :: TyLitMap a-emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }+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 { tlm_number = Map.map f tn, tlm_string = mapUFM f ts }+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     NumTyLit n -> tlm_number >.> Map.lookup n     StrTyLit n -> tlm_string >.> (`lookupUFM` n)+    CharTyLit n -> tlm_char >.> Map.lookup n  xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m =   case l of-    NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }-    StrTyLit n -> m { tlm_string = alterUFM  f (tlm_string m) n }+    NumTyLit n ->  m { tlm_number = Map.alter f n (tlm_number m) }+    StrTyLit n ->  m { tlm_string = alterUFM  f (tlm_string m) n }+    CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }  foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (foldUFM l) (tlm_string m)-              . flip (Map.foldr l)   (tlm_number m)+              . flip (Map.foldr l) (tlm_number m)+              . flip (Map.foldr l) (tlm_char m)  filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a-filterTyLit f (TLM { tlm_number = tn, tlm_string = ts })-  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts }+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }  ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this

@@ -682,7 +682,7 @@ fifteen years ago!  It also shows up in the code for 'rnf' on lists in #4138. -We do the neccessary, quite simple fixed-point iteration in 'findRhsArity',+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 @@ -1339,7 +1339,7 @@ alternative to 'eta'.  We want to beta-reduce all that junk away. -#18223 was a dramtic example in which the intermediate term was+#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. -}

@@ -35,7 +35,6 @@    ( primOpRules    , builtinRules    , caseRules-   , EnableBignumRules (..)    ) where @@ -1676,11 +1675,9 @@ is fine. -} -newtype EnableBignumRules = EnableBignumRules Bool--builtinRules :: EnableBignumRules -> [CoreRule]+builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma-builtinRules enableBignumRules+builtinRules   = [BuiltinRule { ru_name = fsLit "AppendLitString",                    ru_fn = unpackCStringFoldrName,                    ru_nargs = 4, ru_try = match_append_lit_C },@@ -1719,14 +1716,13 @@             `App` arg `App` mkIntVal platform (d - 1)         ]      ]- ++ builtinBignumRules enableBignumRules+ ++ builtinBignumRules {-# NOINLINE builtinRules #-} -- there is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. -builtinBignumRules :: EnableBignumRules -> [CoreRule]-builtinBignumRules (EnableBignumRules False) = []-builtinBignumRules _ =+builtinBignumRules :: [CoreRule]+builtinBignumRules =   [ -- conversions     lit_to_integer "Word# -> Integer"   integerFromWordName   , lit_to_integer "Int64# -> Integer"  integerFromInt64Name@@ -1872,7 +1868,10 @@       { ru_name = fsLit str       , ru_fn = name       , ru_nargs = nargs-      , ru_try = runRuleM f+      , ru_try = runRuleM $ do+          env <- getEnv+          guard (roBignumRules env)+          f       }      integer_to_lit str name convert = mkRule str name 1 $ do

@@ -64,7 +64,8 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable as Outputable-import GHC.Utils.Error ( Severity(..), DumpFormat (..), dumpAction, dumpOptionsFromFlag )+import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )+import GHC.Utils.Error ( Severity(..) ) import GHC.Utils.Monad  import GHC.Data.FastString@@ -172,6 +173,7 @@         , sm_case_case  :: !Bool          -- ^ Whether case-of-case is enabled         , sm_eta_expand :: !Bool          -- ^ Whether eta-expansion is enabled         , 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.             --@@ -180,9 +182,7 @@             --    - Opt_DictsCheap and Opt_PedanticBottoms general flags             --    - rules options (initRuleOpts)             --    - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings-            --    - traceAction, dumpAction             --    - inlineCheck-            --    - touchDumpFile (generatedDumps, etc.)         }  instance Outputable SimplMode where@@ -723,6 +723,9 @@ instance HasDynFlags CoreM where     getDynFlags = fmap hsc_dflags getHscEnv +instance HasLogger CoreM where+    getLogger = fmap hsc_logger getHscEnv+ instance HasModule CoreM where     getModule = read cr_module @@ -789,19 +792,20 @@ -}  msg :: Severity -> WarnReason -> SDoc -> CoreM ()-msg sev reason doc-  = do { dflags <- getDynFlags-       ; loc    <- getSrcSpanM-       ; unqual <- getPrintUnqualified-       ; let sty = case sev of-                     SevError   -> err_sty-                     SevWarning -> err_sty-                     SevDump    -> dump_sty-                     _          -> user_sty-             err_sty  = mkErrStyle unqual-             user_sty = mkUserStyle unqual AllTheWay-             dump_sty = mkDumpStyle unqual-       ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) }+msg sev reason doc = do+    dflags <- getDynFlags+    logger <- getLogger+    loc    <- getSrcSpanM+    unqual <- getPrintUnqualified+    let sty = case sev of+                SevError   -> err_sty+                SevWarning -> err_sty+                SevDump    -> dump_sty+                _          -> user_sty+        err_sty  = mkErrStyle unqual+        user_sty = mkUserStyle unqual AllTheWay+        dump_sty = mkDumpStyle unqual+    liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc)  -- | Output a String message to the screen putMsgS :: String -> CoreM ()@@ -840,9 +844,10 @@  -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()-dumpIfSet_dyn flag str fmt doc-  = do { dflags <- getDynFlags-       ; unqual <- getPrintUnqualified-       ; when (dopt flag dflags) $ liftIO $ do-         let sty = mkDumpStyle unqual-         dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }+dumpIfSet_dyn flag str fmt doc = do+    dflags <- getDynFlags+    logger <- getLogger+    unqual <- getPrintUnqualified+    when (dopt flag dflags) $ liftIO $ do+        let sty = mkDumpStyle unqual+        putDumpMsg logger dflags sty flag str fmt doc

@@ -302,7 +302,7 @@  So, during loop-breaker analysis: -- for each active RULE for a local function 'f' we add an edge bewteen+- for each active RULE for a local function 'f' we add an edge between   'f' and the local FVs of the rule RHS  - for each active RULE for an *imported* function we add dependency@@ -639,7 +639,7 @@           {-# RULES "SPEC k 0" k 0 = j #-}           k x y = x + 2 * y       in ...-  If we eta-expanded the rule all woudl be well, but as it stands the+  If we eta-expanded the rule all would be well, but as it stands the   one arg of the rule don't match the join-point arity of 2.    Conceivably we could notice that a potential join point would have@@ -1932,17 +1932,25 @@     (markAllNonTail body_usage, Lam x body')     } --- For value lambdas we do a special hack.  Consider---      (\x. \y. ...x...)--- If we did nothing, x is used inside the \y, so would be marked--- as dangerous to dup.  But in the common case where the abstraction--- is applied to two arguments this is over-pessimistic.--- So instead, we just mark each binder with its occurrence--- info in the *body* of the multiple lambda.--- Then, the simplifier is careful when partially applying lambdas.+{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations. +So instead, we just mark each binder with its occurrence info in the+*body* of the multiple lambda.  Then, the simplifier is careful when+partially applying lambdas. See the calls to zapLamBndrs in+  GHC.Core.Opt.Simplify.simplExprF1+  GHC.Core.SimpleOpt.simple_app+-}+ occAnal env expr@(Lam _ _)-  = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->+  = -- See Note [Occurrence analysis for lambda binders]+    case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->     let         expr'       = mkLams tagged_bndrs body'         usage1      = markAllNonTail usage

@@ -333,10 +333,21 @@ simple_app env (App e1 e2) as   = simple_app env e1 ((env, e2) : as) -simple_app env (Lam b e) (a:as)-  = wrapLet mb_pr (simple_app env' e as)+simple_app env e@(Lam {}) as@(_:_)+  | (bndrs, body) <- collectBinders e+  , let zapped_bndrs = zapLamBndrs (length as) bndrs+    -- Be careful to zap the lambda binders if necessary+    -- c.f. the Lam caes of simplExprF1 in GHC.Core.Opt.Simplify+    -- Lacking this zap caused #19347, when we had a redex+    --   (\ a b. K a b) e1 e2+    -- where (as it happens) the eta-expanded K is produced by+    -- Note [Linear fields generalization] in GHC.Tc.Gen.Head+  = do_beta env zapped_bndrs body as   where-     (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel+    do_beta env (b:bs) body (a:as)+      | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel+      = wrapLet mb_pr $ do_beta env' bs body as+    do_beta env bs body as = simple_app env (mkLams bs body) as  simple_app env (Tick t e) as   -- Okay to do "(Tick t e) x ==> Tick t (e x)"?

@@ -383,7 +383,7 @@ {- Note [Finding free coercion varibles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here we are only interested in the free /coercion/ variables.-We can achieve this through a slightly differnet TyCo folder.+We can achieve this through a slightly different TyCo folder.  Notice that we look deeply, into kinds. 

@@ -42,7 +42,7 @@         MCoercion(..), MCoercionR, MCoercionN,          -- * Functions over types-        mkTyConTy, mkTyVarTy, mkTyVarTys,+        mkTyConTy_, mkTyVarTy, mkTyVarTys,         mkTyCoVarTy, mkTyCoVarTys,         mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys,         mkForAllTy, mkForAllTys, mkInvisForAllTys,@@ -51,7 +51,6 @@         mkScaledFunTy,         mkVisFunTyMany, mkVisFunTysMany,         mkInvisFunTyMany, mkInvisFunTysMany,-        mkTyConApp,         tYPE,          -- * Functions over binders@@ -91,8 +90,8 @@ import GHC.Core.Coercion.Axiom  -- others-import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey )-import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy )+import GHC.Builtin.Names ( liftedRepDataConKey )+import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKind, manyDataConTy ) import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon ) import GHC.Types.Basic ( LeftOrRight(..), pickLR ) import GHC.Types.Unique ( hasKey, Uniquable(..) )@@ -192,13 +191,19 @@ data TyLit   = NumTyLit Integer   | StrTyLit FastString+  | CharTyLit Char   deriving (Eq, Data.Data)  instance Ord TyLit where-   compare (NumTyLit _) (StrTyLit _) = LT-   compare (StrTyLit _) (NumTyLit _) = GT-   compare (NumTyLit x) (NumTyLit y) = compare x y-   compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y+  compare (NumTyLit x) (NumTyLit y)   = compare x y+  compare (StrTyLit x) (StrTyLit y)   = uniqCompareFS x y+  compare (CharTyLit x) (CharTyLit y) = compare x y+  compare a b = compare (tag a) (tag b)+    where+      tag :: TyLit -> Int+      tag NumTyLit{}  = 0+      tag StrTyLit{}  = 1+      tag CharTyLit{} = 2  instance Outputable TyLit where    ppr = pprTyLit@@ -998,35 +1003,11 @@ mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs --- | Create the plain type constructor type which has been applied to no type arguments at all.-mkTyConTy :: TyCon -> Type-mkTyConTy tycon = TyConApp 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 tys-  | isFunTyCon tycon-  , [w, _rep1,_rep2,ty1,ty2] <- tys-  -- The FunTyCon (->) is always a visible one-  = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }--  -- See Note [Prefer Type over TYPE 'LiftedRep]-  | tycon `hasKey` liftedTypeKindTyConKey-  = ASSERT2( null tys, ppr tycon $$ ppr tys )-    liftedTypeKindTyConApp-  | tycon `hasKey` manyDataConKey-  -- There are a lot of occurrences of 'Many' so it's a small optimisation to-  -- avoid reboxing every time `mkTyConApp` is called.-  = ASSERT2( null tys, ppr tycon $$ ppr tys )-    manyDataConTy-  -- See Note [Prefer Type over TYPE 'LiftedRep].-  | tycon `hasKey` tYPETyConKey-  , [rep] <- tys-  = tYPE rep-  -- The catch-all case-  | otherwise-  = TyConApp tycon tys+-- | Create a nullary 'TyConApp'. In general you should rather use+-- 'GHC.Core.Type.mkTyConTy'. This merely exists to break the import cycle+-- between 'GHC.Core.TyCon' and this module.+mkTyConTy_ :: TyCon -> Type+mkTyConTy_ tycon = TyConApp tycon []  {- Note [Prefer Type over TYPE 'LiftedRep]@@ -1073,16 +1054,9 @@     (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we     don't need to allocate such types (goal (a)). - 3. To avoid allocating 'TyConApp' constructors the-    'GHC.Builtin.Types.Prim.tYPE' function catches the lifted case and returns-    `liftedTypeKind` instead of building an application (goal (a)).-- 4. Similarly, 'Type.mkTyConApp' catches applications of `TYPE` and-    handles them using 'GHC.Builtin.Types.Prim.tYPE', ensuring-    that it benefits from the optimisation described above (goal (a)).--Note that it's quite important that we do not define 'liftedTypeKind' in terms-of 'mkTyConApp' since this tricks (1) and (4) would then result in a loop.+ 3. 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. -}@@ -1095,12 +1069,6 @@   | tc `hasKey` liftedRepDataConKey = liftedTypeKind  -- TYPE 'LiftedRep tYPE rr = TyConApp tYPETyCon [rr] --- This is a single, global definition of the type `Type`--- Defined here so it is only allocated once.--- See Note [Prefer Type over TYPE 'LiftedRep] in this module.-liftedTypeKindTyConApp :: Type-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []- {- %************************************************************************ %*                                                                      *@@ -1903,7 +1871,7 @@       = let !env' = tycobinder env tv vis  -- Avoid building a thunk here         in go_ty env (varType tv) `mappend` go_ty env' inner -    -- Explicit recursion becuase using foldr builds a local+    -- Explicit recursion because using foldr builds a local     -- loop (with env free) and I'm not confident it'll be     -- lambda lifted in the end     go_tys _   []     = mempty

@@ -3,6 +3,7 @@ import GHC.Utils.Outputable ( Outputable ) import Data.Data  ( Data ) import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag )+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )  data Type data Coercion@@ -22,6 +23,7 @@  mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type+mkTyConTy_ :: TyCon -> Type  instance Data Type  -- To support Data instances in GHC.Core.Coercion.Axiom instance Outputable Type

@@ -57,7 +57,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Core.Type-   ( mkCastTy, mkAppTy, isCoercionTy )+   ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp ) import {-# SOURCE #-} GHC.Core.Coercion    ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo    , mkNomReflCo, mkSubCo, mkSymCo

@@ -88,6 +88,7 @@         tyConFamilySize,         tyConStupidTheta,         tyConArity,+        tyConNullaryTy,         tyConRoles,         tyConFlavour,         tyConTuple_maybe, tyConClass_maybe, tyConATs,@@ -135,7 +136,7 @@ import GHC.Platform  import {-# SOURCE #-} GHC.Core.TyCo.Rep-   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany )+   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr    ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types@@ -417,6 +418,20 @@  * [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@@ -718,6 +733,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,          tcRepName :: TyConRepName     }@@ -748,6 +764,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@                -- The tyConTyVars scope over:               --@@ -805,6 +822,7 @@         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@@ -843,6 +861,7 @@         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 @@ -879,6 +898,7 @@         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@@ -904,6 +924,7 @@         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@@ -923,6 +944,7 @@         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)@@ -1602,20 +1624,20 @@ -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm-  = FunTyCon {-        tyConUnique  = nameUnique name,-        tyConName    = name,-        tyConBinders = binders,-        tyConResKind = liftedTypeKind,-        tyConKind    = mkTyConKind binders liftedTypeKind,-        tyConArity   = length binders,-        tcRepName    = rep_nm-    }+  = let tc =+          FunTyCon {+              tyConUnique  = nameUnique name,+              tyConName    = name,+              tyConBinders = binders,+              tyConResKind = liftedTypeKind,+              tyConKind    = mkTyConKind binders liftedTypeKind,+              tyConArity   = length binders,+              tyConNullaryTy = mkTyConTy_ tc,+              tcRepName    = rep_nm+          }+    in tc --- | This is the making of an algebraic 'TyCon'. Notably, you have to--- pass in the generic (in the -XGenerics sense) information about the--- type constructor - you can get hold of it easily (see Generics--- module)+-- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name            -> [TyConBinder]  -- ^ Binders of the 'TyCon'            -> Kind              -- ^ Result kind@@ -1629,22 +1651,25 @@            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?            -> TyCon mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn-  = AlgTyCon {-        tyConName        = name,-        tyConUnique      = nameUnique name,-        tyConBinders     = binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = length binders,-        tyConTyVars      = binderVars binders,-        tcRoles          = roles,-        tyConCType       = cType,-        algTcStupidTheta = stupid,-        algTcRhs         = rhs,-        algTcFields      = fieldsOfAlgTcRhs rhs,-        algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,-        algTcGadtSyntax  = gadt_syn-    }+  = let tc =+          AlgTyCon {+              tyConName        = name,+              tyConUnique      = nameUnique name,+              tyConBinders     = binders,+              tyConResKind     = res_kind,+              tyConKind        = mkTyConKind binders res_kind,+              tyConArity       = length binders,+              tyConNullaryTy   = mkTyConTy_ tc,+              tyConTyVars      = binderVars binders,+              tcRoles          = roles,+              tyConCType       = cType,+              algTcStupidTheta = stupid,+              algTcRhs         = rhs,+              algTcFields      = fieldsOfAlgTcRhs rhs,+              algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+              algTcGadtSyntax  = gadt_syn+          }+    in tc  -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> [TyConBinder]@@ -1664,23 +1689,26 @@              -> AlgTyConFlav              -> TyCon mkTupleTyCon name binders res_kind arity con sort parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = binderVars binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = TupleTyCon { data_con = con,-                                        tup_sort = sort },-        algTcFields      = emptyDFsEnv,-        algTcParent      = 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   = mkTyConTy_ tc,+              tcRoles          = replicate arity Representational,+              tyConCType       = Nothing,+              algTcGadtSyntax  = False,+              algTcStupidTheta = [],+              algTcRhs         = TupleTyCon { data_con = con,+                                              tup_sort = sort },+              algTcFields      = emptyDFsEnv,+              algTcParent      = parent+          }+    in tc  mkSumTyCon :: Name              -> [TyConBinder]@@ -1691,22 +1719,25 @@              -> AlgTyConFlav              -> TyCon mkSumTyCon name binders res_kind arity tyvars cons parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = tyvars,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = mkSumTyConRhs cons,-        algTcFields      = emptyDFsEnv,-        algTcParent      = parent-    }+  = let tc =+          AlgTyCon {+              tyConUnique      = nameUnique name,+              tyConName        = name,+              tyConBinders     = binders,+              tyConTyVars      = tyvars,+              tyConResKind     = res_kind,+              tyConKind        = mkTyConKind binders res_kind,+              tyConArity       = arity,+              tyConNullaryTy   = mkTyConTy_ tc,+              tcRoles          = replicate arity Representational,+              tyConCType       = Nothing,+              algTcGadtSyntax  = False,+              algTcStupidTheta = [],+              algTcRhs         = mkSumTyConRhs cons,+              algTcFields      = emptyDFsEnv,+              algTcParent      = 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@@ -1724,16 +1755,19 @@           -> TyConFlavour        -- ^ What sort of 'TyCon' this represents           -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav-  = TcTyCon { tyConUnique  = getUnique name-            , tyConName    = name-            , tyConTyVars  = binderVars binders-            , tyConBinders = binders-            , tyConResKind = res_kind-            , tyConKind    = mkTyConKind binders res_kind-            , tyConArity   = length binders-            , tcTyConScopedTyVars = scoped_tvs-            , tcTyConIsPoly       = poly-            , tcTyConFlavour      = 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 = mkTyConTy_ tc+                  , tcTyConScopedTyVars = scoped_tvs+                  , tcTyConIsPoly       = poly+                  , tcTyConFlavour      = flav }+    in tc  -- | No scoped type variables (to be used with mkTcTyCon). noTcTyConScopedTyVars :: [(Name, TcTyVar)]@@ -1770,55 +1804,64 @@              -> [Role]              -> Bool -> Maybe TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm-  = PrimTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length roles,-        tcRoles      = roles,-        isUnlifted   = is_unlifted,-        primRepName  = rep_nm-    }+  = let tc =+          PrimTyCon {+              tyConName    = name,+              tyConUnique  = nameUnique name,+              tyConBinders = binders,+              tyConResKind = res_kind,+              tyConKind    = mkTyConKind binders res_kind,+              tyConArity   = length roles,+              tyConNullaryTy = mkTyConTy_ tc,+              tcRoles      = roles,+              isUnlifted   = is_unlifted,+              primRepName  = rep_nm+          }+    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-  = SynonymTyCon {-        tyConName      = name,-        tyConUnique    = nameUnique name,-        tyConBinders   = binders,-        tyConResKind   = res_kind,-        tyConKind      = mkTyConKind binders res_kind,-        tyConArity     = length binders,-        tyConTyVars    = binderVars binders,-        tcRoles        = roles,-        synTcRhs       = rhs,-        synIsTau       = is_tau,-        synIsFamFree   = is_fam_free,-        synIsForgetful = is_forgetful-    }+  = let tc =+          SynonymTyCon {+              tyConName      = name,+              tyConUnique    = nameUnique name,+              tyConBinders   = binders,+              tyConResKind   = res_kind,+              tyConKind      = mkTyConKind binders res_kind,+              tyConArity     = length binders,+              tyConNullaryTy = mkTyConTy_ 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-  = FamilyTyCon-      { tyConUnique  = nameUnique name-      , tyConName    = name-      , tyConBinders = binders-      , tyConResKind = res_kind-      , tyConKind    = mkTyConKind binders res_kind-      , tyConArity   = length binders-      , tyConTyVars  = binderVars binders-      , famTcResVar  = resVar-      , famTcFlav    = flav-      , famTcParent  = classTyCon <$> parent-      , famTcInj     = inj-      }+  = let tc =+          FamilyTyCon+            { tyConUnique  = nameUnique name+            , tyConName    = name+            , tyConBinders = binders+            , tyConResKind = res_kind+            , tyConKind    = mkTyConKind binders res_kind+            , tyConArity   = length binders+            , tyConNullaryTy = mkTyConTy_ tc+            , tyConTyVars  = binderVars binders+            , famTcResVar  = resVar+            , famTcFlav    = flav+            , famTcParent  = classTyCon <$> parent+            , famTcInj     = inj+            }+    in tc   -- | Create a promoted data constructor 'TyCon'@@ -1829,18 +1872,21 @@                   -> [TyConTyCoBinder] -> Kind -> [Role]                   -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info-  = PromotedDataCon {-        tyConUnique   = nameUnique name,-        tyConName     = name,-        tyConArity    = length roles,-        tcRoles       = roles,-        tyConBinders  = binders,-        tyConResKind  = res_kind,-        tyConKind     = mkTyConKind binders res_kind,-        dataCon       = con,-        tcRepName     = rep_name,-        promDcRepInfo = rep_info-  }+  = let tc =+          PromotedDataCon {+            tyConUnique   = nameUnique name,+            tyConName     = name,+            tyConArity    = length roles,+            tyConNullaryTy = mkTyConTy_ 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@@ -2220,7 +2266,11 @@ -- 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 Invariant] in GHC.Tc.Gen.HsType-setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind }+setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind+                                                   , tyConNullaryTy = mkTyConTy_ tc'+                                                       -- see Note [Sharing nullary TyCons]+                                                   }+                                      in tc' setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc)  -- | Could this TyCon ever be levity-polymorphic when fully applied?@@ -2257,13 +2307,14 @@                                   -- type of the synonym (not yet substituted)                                   -- and any arguments remaining from the                                   -- application---- ^ Expand a type synonym application, if any+-- ^ 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-  = case tys of-      [] -> Just ([], rhs, []) -- Avoid a bit of work in the case of nullary synonyms-      _  -> case tys `listLengthCmp` arity of+  = 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

@@ -63,6 +63,7 @@          mkNumLitTy, isNumLitTy,         mkStrLitTy, isStrLitTy,+        mkCharLitTy, isCharLitTy,         isLitTy,          isPredTy,@@ -255,7 +256,7 @@ import GHC.Core.TyCon import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types-                                 ( naturalTy, listTyCon+                                 ( charTy, naturalTy, listTyCon                                  , typeSymbolKind, liftedTypeKind                                  , constraintKind                                  , unrestrictedFunTyCon@@ -1074,7 +1075,17 @@   | LitTy (StrTyLit s) <- coreFullView ty = Just s   | otherwise                             = Nothing --- | Is this a type literal (symbol or numeric).+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@@ -1147,7 +1158,7 @@     FunTy (Anon a) b  Note how the RuntimeReps are implied in the FunTy representation. For this-reason we must be careful when recontructing the TyConApp representation (see,+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@@ -1479,7 +1490,32 @@     to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)     to_tyb (Bndr tv (AnonTCB af))   = Anon af (tymult (varType tv)) +-- | Create the plain type constructor type which has been applied to no type arguments at all.+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = tyConNullaryTy tycon+  -- see Note [Sharing nullary TyConApps] in GHC.Core.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 tys+  | [] <- tys+  = mkTyConTy tycon++  | isFunTyCon tycon+  , [w, _rep1,_rep2,ty1,ty2] <- tys+  -- The FunTyCon (->) is always a visible one+  = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }++  -- See Note [Prefer Type over TYPE 'LiftedRep].+  | tycon `hasKey` tYPETyConKey+  , [rep] <- tys+  = tYPE rep+  -- The catch-all case+  | otherwise+  = TyConApp tycon tys++ {- --------------------------------------------------------------------                             CoercionTy@@ -2243,7 +2279,6 @@ 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@@ -2270,7 +2305,7 @@  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 [Prefer Type over TYPE 'LiftedRep] in+whenever possible. See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep for details.  -}@@ -2684,6 +2719,7 @@ typeLiteralKind :: TyLit -> Kind typeLiteralKind (NumTyLit {}) = naturalTy typeLiteralKind (StrTyLit {}) = typeSymbolKind+typeLiteralKind (CharTyLit {}) = charTy  -- | Returns True if a type is levity polymorphic. Should be the same -- as (isKindLevPoly . typeKind) but much faster.

@@ -12,6 +12,8 @@  mkAppTy    :: Type -> Type -> Type mkCastTy   :: Type -> Coercion -> Type+mkTyConTy  :: TyCon -> Type+mkTyConApp :: TyCon -> [Type] -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type  coreView :: Type -> Maybe Type

@@ -26,7 +26,7 @@         UnfoldingOpts (..), defaultUnfoldingOpts,         updateCreationThreshold, updateUseThreshold,         updateFunAppDiscount, updateDictDiscount,-        updateVeryAggressive,+        updateVeryAggressive, updateCaseScaling, updateCaseThreshold,          ArgSummary(..), @@ -56,11 +56,11 @@ import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag+import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.ForeignCall import GHC.Types.Name-import GHC.Utils.Error  import qualified Data.ByteString as BS import Data.List (isPrefixOf)@@ -82,6 +82,12 @@     , unfoldingVeryAggressive :: !Bool       -- ^ Force inlining in many more cases++      -- Don't consider depth up to x+   , unfoldingCaseThreshold :: !Int++      -- Penalize depth with 1/x+   , unfoldingCaseScaling :: !Int    }  defaultUnfoldingOpts :: UnfoldingOpts@@ -106,6 +112,13 @@       -- we'll be able to pick the right method from a dictionary     , unfoldingVeryAggressive = False++      -- Only apply scaling once we are deeper than threshold cases+      -- in an RHS.+   , unfoldingCaseThreshold = 2++      -- Penalize depth with (size*depth)/scaling+   , unfoldingCaseScaling = 30    }  -- Helpers for "GHC.Driver.Session"@@ -125,6 +138,13 @@ updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n } ++updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n }++updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling n opts = opts { unfoldingCaseScaling = n }+ {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -810,7 +830,7 @@ Note [Discounts and thresholds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constants for discounts and thesholds are defined in 'UnfoldingOpts'. They are:+Constants for discounts and thresholds are defined in 'UnfoldingOpts'. They are:  unfoldingCreationThreshold      At a definition site, if the unfolding is bigger than this, we@@ -936,11 +956,21 @@ -- ^ Sees if the unfolding is pretty certain to inline. -- If so, return a *stable* unfolding for it, that will always inline. certainlyWillInline opts fn_info-  = case unfoldingInfo fn_info of-      CoreUnfolding { uf_tmpl = e, uf_guidance = g }-        | loop_breaker -> Nothing      -- Won't inline, so try w/w-        | noinline     -> Nothing      -- See Note [Worker-wrapper for NOINLINE functions]-        | otherwise    -> do_cunf e g  -- Depends on size, so look at that+  = case fn_unf of+      CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src }+        | loop_breaker -> Nothing       -- Won't inline, so try w/w+        | noinline     -> Nothing       -- See Note [Worker-wrapper for NOINLINE functions]+        | otherwise+        -> case guidance of+             UnfNever  -> Nothing+             UnfWhen {} -> Just (fn_unf { uf_src = src' })+                             -- INLINE functions have UnfWhen+             UnfIfGoodArgs { ug_size = size, ug_args = args }+               -> do_cunf expr size args src'+        where+          src' = case src of+                   InlineRhs -> InlineStable+                   _         -> src  -- Do not change InlineCompulsory!        DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense                                        -- to do so, and even if it is currently a@@ -953,17 +983,12 @@     noinline     = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline     fn_unf       = unfoldingInfo fn_info -    do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding-    do_cunf _ UnfNever     = Nothing-    do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable })-                             -- INLINE functions have UnfWhen-         -- The UnfIfGoodArgs case seems important.  If we w/w small functions         -- binary sizes go up by 10%!  (This is with SplitObjs.)         -- I'm not totally sure why.         -- INLINABLE functions come via this path         --    See Note [certainlyWillInline: INLINABLE]-    do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })+    do_cunf expr size args src'       | arityInfo fn_info > 0  -- See Note [certainlyWillInline: be careful of thunks]       , not (isDeadEndSig (strictnessInfo fn_info))               -- Do not unconditionally inline a bottoming functions even if@@ -971,7 +996,7 @@               -- so we don't want to re-inline it.       , let unf_arity = length args       , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts-      = Just (fn_unf { uf_src      = InlineStable+      = Just (fn_unf { uf_src      = src'                      , uf_guidance = UnfWhen { ug_arity     = unf_arity                                              , ug_unsat_ok  = unSaturatedOk                                              , ug_boring_ok = inlineBoringOk expr } })@@ -1032,7 +1057,9 @@ StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: DynFlags+callSiteInline :: Logger+               -> DynFlags+               -> Int                   -- Case depth                -> Id                    -- The Id                -> Bool                  -- True <=> unfolding is active                -> Bool                  -- True if there are no arguments at all (incl type args)@@ -1075,7 +1102,7 @@   ppr DiscArgCtxt = text "DiscArgCtxt"   ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info+callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_infos cont_info   = case idUnfolding id of       -- idUnfolding checks for loop-breakers, returning NoUnfolding       -- Things with an INLINE pragma may have an unfolding *and*@@ -1083,22 +1110,22 @@         CoreUnfolding { uf_tmpl = unf_template                       , uf_is_work_free = is_wf                       , uf_guidance = guidance, uf_expandable = is_exp }-          | active_unfolding -> tryUnfolding dflags id lone_variable+          | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable                                     arg_infos cont_info unf_template                                     is_wf is_exp guidance-          | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing+          | otherwise -> traceInline logger dflags id "Inactive unfolding:" (ppr id) Nothing         NoUnfolding      -> Nothing         BootUnfolding    -> Nothing         OtherCon {}      -> Nothing         DFunUnfolding {} -> Nothing     -- Never unfold a DFun  -- | Report the inlining of an identifier's RHS to the user, if requested.-traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a-traceInline dflags inline_id str doc result+traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a+traceInline logger dflags inline_id str doc result   -- We take care to ensure that doc is used in only one branch, ensuring that   -- the simplifier can push its allocation into the branch. See Note [INLINE   -- conditional tracing utilities].-  | enable    = traceAction dflags str doc result+  | enable    = putTraceMsg logger dflags str doc result   | otherwise = result   where     enable@@ -1110,37 +1137,140 @@       = False {-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt+{- Note [Avoid inlining into deeply nested cases]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a function f like this:++  f arg1 arg2 =+    case ...+      ... -> g arg1+      ... -> g arg2++This function is small. So should be safe to inline.+However sometimes this doesn't quite work out like that.+Consider this code:++f1 arg1 arg2 ... = ...+    case _foo of+      alt1 -> ... f2 arg1 ...+      alt2 -> ... f2 arg2 ...++f2 arg1 arg2 ... = ...+    case _foo of+      alt1 -> ... f3 arg1 ...+      alt2 -> ... f3 arg2 ...++f3 arg1 arg2 ... = ...++... repeats up to n times. And then f1 is+applied to some arguments:++foo = ... f1 <interestingArgs> ...++Initially f2..fn are not interesting to inline so we don't.+However we see that f1 is applied to interesting args.+So it's an obvious choice to inline those:++foo =+    ...+      case _foo of+        alt1 -> ... f2 <interestingArg> ...+        alt2 -> ... f2 <interestingArg> ...++As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting+arguments and f2 is small:++foo =+    ...+      case _foo of+        alt1 -> ... case _foo of+            alt1 -> ... f3 <interestingArg> ...+            alt2 -> ... f3 <interestingArg> ...++        alt2 -> ... case _foo of+            alt1 -> ... f3 <interestingArg> ...+            alt2 -> ... f3 <interestingArg> ...++The same thing happens for each binding up to f_n, duplicating the amount of inlining+done in each step. Until at some point we are either done or run out of simplifier+ticks/RAM. This pattern happened #18730.++To combat this we introduce one more heuristic when weighing inlining decision.+We keep track of a "case-depth". Which increases each time we look inside a case+expression with more than one alternative.++We then apply a penalty to inlinings based on the case-depth at which they would+be inlined. Bounding the number of inlinings in such a scenario.++The heuristic can be tuned in two ways:++* We can ignore the first n levels of case nestings for inlining decisions using+  -funfolding-case-threshold.+* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling.+  Scaling can be set with -funfolding-case-scaling.++Some guidance on setting these defaults:++* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of+  control. We picked 2 for no particular reason.+* Scaling the penalty by any more than 30 means the reproducer from+  T18730 won't compile even with reasonably small values of n. Instead+  it will run out of runs/ticks. This means to positively affect the reproducer+  a scaling <= 30 is required.+* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.+  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)+* A scaling of >= 25 showed no regressions on nofib. However it showed a number of+  (small) regression for compiler perf benchmarks.++The end result is that we are settling for a scaling of 30, with a threshold of 2.+This gives us minimal compiler perf regressions. No nofib runtime regressions and+will still avoid this pattern sometimes. This is a "safe" default, where we err on+the side of compiler blowup instead of risking runtime regressions.++For cases where the default falls short the flag can be changed to allow more/less inlining as+needed on a per-module basis.++-}++tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance              -> Maybe CoreExpr-tryUnfolding dflags id lone_variable+tryUnfolding logger dflags !case_depth id lone_variable              arg_infos cont_info unf_template              is_wf is_exp guidance  = case guidance of-     UnfNever -> traceInline dflags id str (text "UnfNever") Nothing+     UnfNever -> traceInline logger dflags id str (text "UnfNever") Nothing       UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }         | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive uf_opts)                 -- See Note [INLINE for small functions (3)]-        -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)+        -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template)         | otherwise-        -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing+        -> traceInline logger dflags id str (mk_doc some_benefit empty False) Nothing         where           some_benefit = calc_some_benefit uf_arity           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)       UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }         | unfoldingVeryAggressive uf_opts-        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | is_wf && some_benefit && small_enough-        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | otherwise-        -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc False) Nothing         where           some_benefit = calc_some_benefit (length arg_discounts)-          extra_doc = text "discounted size =" <+> int discounted_size-          discounted_size = size - discount-          small_enough = discounted_size <= unfoldingUseThreshold uf_opts+          extra_doc = vcat [ text "case depth =" <+> int case_depth+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "discounted size =" <+> int adjusted_size ]+          -- See Note [Avoid inlining into deeply nested cases]+          depth_treshold = unfoldingCaseThreshold uf_opts+          depth_scaling = unfoldingCaseScaling uf_opts+          depth_penalty | case_depth <= depth_treshold = 0+                        | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling+          adjusted_size = size + depth_penalty - discount+          small_enough = adjusted_size <= unfoldingUseThreshold uf_opts           discount = computeDiscount arg_discounts res_discount arg_infos cont_info    where

@@ -11,3 +11,5 @@ updateFunAppDiscount    :: Int -> UnfoldingOpts -> UnfoldingOpts updateDictDiscount      :: Int -> UnfoldingOpts -> UnfoldingOpts updateVeryAggressive    :: Bool -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold     :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling       :: Int -> UnfoldingOpts -> UnfoldingOpts

@@ -2,7 +2,7 @@  {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}  module GHC.Core.Unify (         tcMatchTy, tcMatchTyKi,@@ -11,8 +11,8 @@         tcMatchTyX_BM, ruleMatchTyKiX,          -- * Rough matching-        roughMatchTcs, instanceCantMatch,-        typesCantMatch,+        RoughMatchTc(..), roughMatchTcs, instanceCantMatch,+        typesCantMatch, isRoughOtherTc,          -- Side-effect free unification         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,@@ -53,6 +53,7 @@ import GHC.Utils.Panic import GHC.Data.FastString +import Data.Data ( Data ) import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S@@ -258,26 +259,70 @@ *                                                                      * ********************************************************************* -} --- See Note [Rough match] field in GHC.Core.InstEnv+{- Note [Rough matching in class and family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  instance C (Maybe [Tree a]) Bool+and suppose we are looking up+     C Bool Bool -roughMatchTcs :: [Type] -> [Maybe Name]+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.+-}++data RoughMatchTc+  = 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]+  | OtherTc        -- e.g. type variable at the head+  deriving( Data )++isRoughOtherTc :: RoughMatchTc -> Bool+isRoughOtherTc OtherTc      = True+isRoughOtherTc (KnownTc {}) = False++roughMatchTcs :: [Type] -> [RoughMatchTc] roughMatchTcs tys = map rough tys   where     rough ty       | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'-      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)-      | otherwise                               = Nothing+      | Just (tc,_)   <- splitTyConApp_maybe ty+      , not (isTypeFamilyTyCon tc)              = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )+                                                  KnownTc (tyConName tc)+        -- See Note [Rough matching in class and family instances]+      | otherwise                               = OtherTc -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+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 :: Maybe Name -> Maybe Name -> Bool-itemCantMatch (Just t) (Just a) = t /= a-itemCantMatch _        _        = False+itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool+itemCantMatch (KnownTc t) (KnownTc a) = t /= a+itemCantMatch _           _           = False   {-@@ -529,7 +574,7 @@                             SurelyApart     -> SurelyApart   Unifiable x  >>= f = f x --- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose+-- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts to find a substitution @s@ (whose -- domain elements all respond 'BindMe' to @bind_tv@) such that -- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned -- Coercions. This version requires that the kinds of the types are the same,

@@ -40,8 +40,8 @@         cheapEqExpr, cheapEqExpr', eqExpr,         diffExpr, diffBinds, -        -- * Eta reduction-        tryEtaReduce,+        -- * Lambdas and eta reduction+        tryEtaReduce, zapLamBndrs,          -- * Manipulating data constructors and types         exprToType, exprToCoercion_maybe,@@ -99,7 +99,7 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList )-import GHC.Types.Basic     ( Arity )+import GHC.Types.Basic     ( Arity, FullArgCount ) import GHC.Utils.Misc import GHC.Data.Pair import Data.ByteString     ( ByteString )@@ -1642,6 +1642,8 @@         -> False       --     for the special cases for SeqOp and DataToTagOp         | DataToTagOp <- op         -> False+        | KeepAliveOp <- op+        -> False          | otherwise         -> primop_ok op  -- Check the primop itself@@ -2521,9 +2523,34 @@ we can eta-reduce    \x. f x  ===>  f  This turned up in #7542.+-} +{- *********************************************************************+*                                                                      *+                  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 under the \x+-- 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+++{- ********************************************************************* *                                                                      * \subsection{Determining non-updatable right-hand-sides} *                                                                      *

@@ -259,6 +259,7 @@ toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x+toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x  ---------------- toIfaceCoercion :: Coercion -> IfaceCoercion

@@ -34,7 +34,7 @@ newFastMutInt = IO $ \s ->   case newByteArray# size s of { (# s, arr #) ->   (# s, FastMutInt arr #) }-  where !(I# size) = finiteBitSize (0 :: Int)+  where !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3  readFastMutInt (FastMutInt arr) = IO $ \s ->   case readIntArray# arr 0# s of { (# s, i #) ->@@ -50,7 +50,7 @@   case newByteArray# size s of { (# s, arr #) ->   (# s, FastMutPtr arr #) }   -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)'-  where !(I# size) = finiteBitSize (0 :: Int)+  where !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3  readFastMutPtr (FastMutPtr arr) = IO $ \s ->   case readAddrArray# arr 0# s of { (# s, i #) ->

@@ -72,6 +72,7 @@          -- ** Deconstruction         unpackFS,           -- :: FastString -> String+        unconsFS,           -- :: FastString -> Maybe (Char, FastString)          -- ** Encoding         zEncodeFS,@@ -607,6 +608,12 @@  consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs)++unconsFS :: FastString -> Maybe (Char, FastString)+unconsFS fs =+  case unpackFS fs of+    []          -> Nothing+    (chr : str) -> Just (chr, mkFastString str)  uniqueOfFS :: FastString -> Int uniqueOfFS fs = uniq fs

@@ -36,6 +36,7 @@ import GHC.Prelude  import GHC.Driver.Session+import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Utils.Exception import GHC.Unit.Module import GHC.Utils.Panic@@ -48,8 +49,11 @@ import Control.Monad.Trans.Reader import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import GHC.Utils.Monad+import GHC.Utils.Logger import Control.Applicative (Alternative(..)) import GHC.Exts( oneShot )+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)+import Control.Concurrent (forkIO, killThread)  ---------------------------------------------------------------------- -- Defining the monad type@@ -110,6 +114,15 @@     getDynFlags = do env <- getEnv                      return $! extractDynFlags env +instance ContainsHooks env => HasHooks (IOEnv env) where+    getHooks = do env <- getEnv+                  return $! extractHooks env++instance ContainsLogger env => HasLogger (IOEnv env) where+    getLogger = do env <- getEnv+                   return $! extractLogger env++ instance ContainsModule env => HasModule (IOEnv env) where     getModule = do env <- getEnv                    return $ extractModule env@@ -150,12 +163,26 @@ tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) tryIOEnvFailure = try --- XXX We shouldn't be catching everything, e.g. timeouts tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)--- Catch *all* exceptions+-- Catch *all* synchronous exceptions -- This is used when running a Template-Haskell splice, when -- even a pattern-match failure is a programmer error-tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))+tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env))++-- | Like 'try', but doesn't catch asynchronous exceptions+safeTry :: IO a -> IO (Either SomeException a)+safeTry act = do+  var <- newEmptyMVar+  -- uninterruptible because we want to mask around 'killThread', which is interruptible.+  uninterruptibleMask $ \restore -> do+    -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it+    t <- forkIO $ try (restore act) >>= putMVar var+    restore (readMVar var)+      `catch` \(e :: SomeException) -> do+        -- Control reaches this point only if the parent thread was sent an async exception+        -- In that case, kill the 'act' thread and re-raise the exception+        killThread t+        throwIO e  tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))

@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2012@@ -6,25 +9,28 @@  -- | Monadic streams module GHC.Data.Stream (-    Stream(..), yield, liftIO,-    collect, collect_, consume, fromList,-    map, mapM, mapAccumL, mapAccumL_+    Stream(..), StreamS(..), runStream, yield, liftIO,+    collect,  consume, fromList,+    map, mapM, mapAccumL_   ) where  import GHC.Prelude hiding (map,mapM)  import Control.Monad hiding (mapM)+import Control.Monad.IO.Class  -- | -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence -- of elements of type @a@ followed by a result of type @b@. ----- More concretely, a value of type @Stream m a b@ can be run using @runStream@+-- More concretely, a value of type @Stream m a b@ can be run using @runStreamInternal@ -- in the Monad @m@, and it delivers either -----  * the final result: @Left b@, or---  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@---    is a computation to get the rest of the stream.+--  * the final result: @Done b@, or+--  * @Yield a str@ where @a@ is the next element in the stream, and @str@+--     is the rest of the stream+--  * @Effect mstr@ where @mstr@ is some action running in @m@ which+--  generates the rest of the stream. -- -- Stream is itself a Monad, and provides an operation 'yield' that -- produces a new element of the stream.  This makes it convenient to turn@@ -38,57 +44,73 @@ -- Stream, and the consumer pulls on the stream each time it wants a -- new value. ---newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }+-- 'Stream' is implemented in the "yoneda" style for efficiency. By+-- representing a stream in this manner 'fmap' and '>>=' operations are+-- accumulated in the function parameters before being applied once when+-- the stream is destroyed. In the old implementation each usage of 'mapM'+-- and '>>=' would traverse the entire stream in order to apply the+-- substitution at the leaves.+--+-- The >>= operation for 'Stream' was a hot-spot in the ticky profile for+-- the "ManyConstructors" test which called the 'cg' function many times in+-- @StgToCmm.hs@+--+newtype Stream m a b =+          Stream { runStreamInternal :: forall r' r .+                                        (a -> m r') -- For fusing calls to `map` and `mapM`+                                     -> (b -> StreamS m r' r)  -- For fusing `>>=`+                                     -> StreamS m r' r } -instance Monad f => Functor (Stream f a) where+runStream :: Applicative m => Stream m r' r -> StreamS m r' r+runStream st = runStreamInternal st pure Done++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 -instance Monad m => Applicative (Stream m a) where-  pure a = Stream (return (Left a))+instance Monad m => Applicative (StreamS m a) where+  pure = Done   (<*>) = ap -instance Monad m => Monad (Stream m a) where+instance Monad m => Monad (StreamS m a) where+  a >>= k = case a of+                      Done r -> k r+                      Yield a s -> Yield a (s >>= k)+                      Effect m -> Effect (fmap (>>= k) m) -  Stream m >>= k = Stream $ do-                r <- m-                case r of-                  Left b        -> runStream (k b)-                  Right (a,str) -> return (Right (a, str >>= k))+instance Functor (Stream f a) where+  fmap = liftM -yield :: Monad m => a -> Stream m a ()-yield a = Stream (return (Right (a, return ())))+instance Applicative (Stream m a) where+  pure a = Stream $ \_f g -> g a+  (<*>) = ap -liftIO :: IO a -> Stream IO b a-liftIO io = Stream $ io >>= return . Left+instance Monad (Stream m a) where+  Stream m >>= k = Stream $ \f h -> m f (\a -> runStreamInternal (k a) f h) --- | Turn a Stream into an ordinary list, by demanding all the elements.-collect :: Monad m => Stream m a () -> m [a]-collect str = go str []- where-  go str acc = do-    r <- runStream str-    case r of-      Left () -> return (reverse acc)-      Right (a, str') -> go str' (a:acc)+instance MonadIO m => MonadIO (Stream m b) where+  liftIO io = Stream $ \_f g -> Effect (g <$> liftIO io) +yield :: Monad m => a -> Stream m a ()+yield a = Stream $ \f rest -> Effect (flip Yield (rest ())  <$> f a)+ -- | Turn a Stream into an ordinary list, by demanding all the elements.-collect_ :: Monad m => Stream m a r -> m ([a], r)-collect_ str = go str []+collect :: Monad m => Stream m a () -> m [a]+collect str = go [] (runStream str)  where-  go str acc = do-    r <- runStream str-    case r of-      Left r -> return (reverse acc, r)-      Right (a, str') -> go str' (a:acc)+  go acc (Done ()) = return (reverse acc)+  go acc (Effect m) = m >>= go acc+  go acc (Yield a k) = go (a:acc) k -consume :: Monad m => Stream m a b -> (a -> m ()) -> m b-consume str f = do-    r <- runStream str-    case r of-      Left ret -> return ret-      Right (a, str') -> do-        f a-        consume str' f+consume :: (Monad m, Monad n) => Stream m a b -> (forall a . m a -> n a) -> (a -> n ()) -> n b+consume str l f = go (runStream str)+  where+    go (Done r) = return r+    go (Yield a p) = f a >> go p+    go (Effect m)  = l m >>= go  -- | Turn a list into a 'Stream', by yielding each element in turn. fromList :: Monad m => [a] -> Stream m a ()@@ -96,40 +118,27 @@  -- | Apply a function to each element of a 'Stream', lazily map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x-map f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> return (Right (f a, map f str'))+map f str = Stream $ \g h -> runStreamInternal str (g . f) h  -- | Apply a monadic operation to each element of a 'Stream', lazily mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x-mapM f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> do-        b <- f a-        return (Right (b, mapM f str'))---- | analog of the list-based 'mapAccumL' on Streams.  This is a simple--- way to map over a Stream while carrying some state around.-mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()-          -> Stream m b c-mapAccumL f c str = Stream $ do-  r <- runStream str-  case r of-    Left  () -> return (Left c)-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL f c' str'))+mapM f str = Stream $ \g h -> runStreamInternal str (g <=< f) h -mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r+-- | 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.+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 $ do-  r <- runStream str-  case r of-    Left  r -> return (Left (c, r))-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL_ f c' str'))+mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str)++  where+    go :: c+             -> (b -> m r')+             -> ((c, r) -> StreamS m r' r1)+             -> StreamS m a r+             -> StreamS m r' r1+    go c _f1 h1 (Done r) = h1 (c, r)+    go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b+                                           >>= \r' -> return $ Yield r' (go c' f1 h1 p)))+    go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)

@@ -68,6 +68,12 @@ import GHC.Exts  import Foreign+#if MIN_VERSION_base(4,15,0)+import GHC.ForeignPtr (unsafeWithForeignPtr)+#else+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+unsafeWithForeignPtr = withForeignPtr+#endif  -- ----------------------------------------------------------------------------- -- The StringBuffer type@@ -107,7 +113,7 @@    offset_i <- skipBOM h size_i 0  -- offset is 0 initially    let size = fromIntegral $ size_i - offset_i    buf <- mallocForeignPtrArray (size+3)-   withForeignPtr buf $ \ptr -> do+   unsafeWithForeignPtr buf $ \ptr -> do      r <- if size == 0 then return 0 else hGetBuf h ptr size      hClose h      if (r /= size)@@ -120,7 +126,7 @@          offset_i <- hTell handle >>= skipBOM handle size_i          let size = min wanted (fromIntegral $ size_i-offset_i)          buf <- mallocForeignPtrArray (size+3)-         withForeignPtr buf $ \ptr ->+         unsafeWithForeignPtr buf $ \ptr ->              do r <- if size == 0 then return 0 else hGetBuf handle ptr size                 if r /= size                    then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))@@ -128,7 +134,7 @@  hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur)-    = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->+    = unsafeWithForeignPtr (plusForeignPtr buf cur) $ \ptr ->           hPutBuf hdl ptr len  -- | Skip the byte-order mark if there is one (see #1744 and #6016),@@ -165,9 +171,9 @@ appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer appendStringBuffers sb1 sb2     = do newBuf <- mallocForeignPtrArray (size+3)-         withForeignPtr newBuf $ \ptr ->-          withForeignPtr (buf sb1) $ \sb1Ptr ->-           withForeignPtr (buf sb2) $ \sb2Ptr ->+         unsafeWithForeignPtr newBuf $ \ptr ->+          unsafeWithForeignPtr (buf sb1) $ \sb1Ptr ->+           unsafeWithForeignPtr (buf sb2) $ \sb2Ptr ->              do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len                 copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len                 pokeArray (ptr `advancePtr` size) [0,0,0]@@ -184,7 +190,7 @@  unsafePerformIO $ do   let size = utf8EncodedLength str   buf <- mallocForeignPtrArray (size+3)-  withForeignPtr buf $ \ptr -> do+  unsafeWithForeignPtr buf $ \ptr -> do     utf8EncodeString ptr str     pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]     -- sentinels for UTF-8 decoding@@ -203,7 +209,7 @@ nextChar (StringBuffer buf len (I# cur#)) =   -- Getting our fingers dirty a little here, but this is performance-critical   inlinePerformIO $-    withForeignPtr buf $ \(Ptr a#) ->+    unsafeWithForeignPtr buf $ \(Ptr a#) ->         case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of           (# c#, nBytes# #) ->              let cur' = I# (cur# +# nBytes#) in@@ -220,7 +226,7 @@ prevChar (StringBuffer _   _   0)   deflt = deflt prevChar (StringBuffer buf _   cur) _     =   inlinePerformIO $-    withForeignPtr buf $ \p -> do+    unsafeWithForeignPtr buf $ \p -> do       p' <- utf8PrevChar (p `plusPtr` cur)       return (fst (utf8DecodeChar p')) @@ -258,7 +264,7 @@ atLine :: Int -> StringBuffer -> Maybe StringBuffer atLine line sb@(StringBuffer buf len _) =   inlinePerformIO $-    withForeignPtr buf $ \p -> do+    unsafeWithForeignPtr buf $ \p -> do       p' <- skipToLine line len p       if p' == nullPtr         then return Nothing@@ -309,14 +315,14 @@ lexemeToFastString _ 0 = nilFS lexemeToFastString (StringBuffer buf _ cur) len =    inlinePerformIO $-     withForeignPtr buf $ \ptr ->+     unsafeWithForeignPtr buf $ \ptr ->        return $! mkFastStringBytes (ptr `plusPtr` cur) len  -- | Return the previous @n@ characters (or fewer if we are less than @n@ -- characters into the buffer. decodePrevNChars :: Int -> StringBuffer -> String decodePrevNChars n (StringBuffer buf _ cur) =-    inlinePerformIO $ withForeignPtr buf $ \p0 ->+    inlinePerformIO $ unsafeWithForeignPtr buf $ \p0 ->       go p0 n "" (p0 `plusPtr` (cur - 1))   where     go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String

@@ -68,7 +68,7 @@ runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do     (a, w) <- hsc hsc_env emptyBag-    printOrThrowWarnings (hsc_dflags hsc_env) w+    printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w     return a  -- | Switches in the DynFlags and Plugins from the InteractiveContext@@ -285,4 +285,3 @@  mainModIs :: HscEnv -> Module mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))-

@@ -4,6 +4,7 @@   , HscEnv(..)   ) where +import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Session ( DynFlags, HasDynFlags(..) ) import GHC.Linker.Types ( Loader ) import GHC.Prelude@@ -20,6 +21,7 @@ import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Types+import GHC.Utils.Logger import {-# SOURCE #-} GHC.Driver.Plugins  import Control.Monad ( ap )@@ -45,6 +47,10 @@ instance HasDynFlags Hsc where     getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasLogger Hsc where+    getLogger = Hsc $ \e w -> return (hsc_logger e, w)++ -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. It's also used@@ -147,5 +153,11 @@                 --                 -- Initialized from the databases cached in 'hsc_unit_dbs' and                 -- from the DynFlags.++        , hsc_logger :: !Logger+                -- ^ Logger++        , hsc_hooks :: !Hooks+                -- ^ Hooks  } 

@@ -9,12 +9,13 @@ import GHC.Driver.Session import GHC.Data.Bag import GHC.Utils.Exception-import GHC.Utils.Error ( formatErrDoc, sortMsgBag )+import GHC.Utils.Error ( formatBulleted, sortMsgBag ) import GHC.Types.SourceError ( mkSrcErr ) import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )+import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine  -- | Converts a list of 'WarningMessages' into a tuple where the second element contains only@@ -28,33 +29,33 @@         Right warn{ errMsgSeverity = SevError                   , errMsgReason = ErrReason err_reason } -printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (ErrMsg a) -> IO ()-printBagOfErrors dflags bag_of_errors+printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()+printBagOfErrors logger dflags bag_of_errors   = sequence_ [ let style = mkErrStyle unqual                     ctx   = initSDocContext dflags style-                in putLogMsg dflags reason sev s-                $ withPprStyle style (formatErrDoc ctx (renderDiagnostic doc))-              | ErrMsg { errMsgSpan      = s,-                         errMsgDiagnostic = doc,-                         errMsgSeverity  = sev,-                         errMsgReason    = reason,-                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)-                                                                  bag_of_errors ]+                in putLogMsg logger dflags reason sev s $+                   withPprStyle style (formatBulleted ctx (renderDiagnostic doc))+              | MsgEnvelope { errMsgSpan      = s,+                              errMsgDiagnostic = doc,+                              errMsgSeverity  = sev,+                              errMsgReason    = reason,+                              errMsgContext   = unqual } <- sortMsgBag (Just dflags)+                                                                       bag_of_errors ] -handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()-handleFlagWarnings dflags warns = do+handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()+handleFlagWarnings logger dflags warns = do   let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason)  warns -      -- It would be nicer if warns :: [Located MsgDoc], but that+      -- It would be nicer if warns :: [Located SDoc], but that       -- has circular import problems.       bag = listToBag [ mkPlainWarnMsg loc (text warn)                       | CmdLine.Warn _ (L loc warn) <- warns' ] -  printOrThrowWarnings dflags bag+  printOrThrowWarnings logger dflags bag  -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)-isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}+isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag}   = if wopt_fatal wflag dflags       then Just (Just wflag)       else Nothing@@ -74,8 +75,8 @@  -- | Given a bag of warnings, turn them into an exception if -- -Werror is enabled, or print them out otherwise.-printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()-printOrThrowWarnings dflags warns = do+printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()+printOrThrowWarnings logger dflags warns = do   let (make_error, warns') =         mapAccumBagL           (\make_err warn ->@@ -89,4 +90,4 @@           False warns   if make_error     then throwIO (mkSrcErr warns')-    else printBagOfErrors dflags warns+    else printBagOfErrors logger dflags warns

@@ -505,6 +505,7 @@    | Opt_WarnInvalidHaddock               -- Since 8.12    | Opt_WarnOperatorWhitespaceExtConflict  -- Since 9.2    | Opt_WarnOperatorWhitespace             -- Since 9.2+   | Opt_WarnAmbiguousFields                -- Since 9.2    deriving (Eq, Show, Enum)  -- | Used when outputting warnings: if a reason is given, it is

@@ -7,9 +7,9 @@  module GHC.Driver.Hooks    ( Hooks+   , HasHooks (..)+   , ContainsHooks (..)    , emptyHooks-   , lookupHook-   , getHooked      -- the hooks:    , DsForeignsHook    , dsForeignsHook@@ -68,7 +68,6 @@ import GHC.Data.Stream import GHC.Data.Bag -import Data.Maybe import qualified Data.Kind import System.Process @@ -125,33 +124,33 @@ type family DsForeignsHook :: Data.Kind.Type  data Hooks = Hooks-  { dsForeignsHook         :: Maybe DsForeignsHook+  { dsForeignsHook         :: !(Maybe DsForeignsHook)   -- ^ Actual type:   -- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@-  , tcForeignImportsHook   :: Maybe ([LForeignDecl GhcRn]-                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))-  , tcForeignExportsHook   :: Maybe ([LForeignDecl GhcRn]-            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))-  , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)+  , tcForeignImportsHook   :: !(Maybe ([LForeignDecl GhcRn]+                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , tcForeignExportsHook   :: !(Maybe ([LForeignDecl GhcRn]+            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , hscFrontendHook        :: !(Maybe (ModSummary -> Hsc FrontendResult))   , hscCompileCoreExprHook ::-               Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)-  , ghcPrimIfaceHook       :: Maybe ModIface-  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))-  , runMetaHook            :: Maybe (MetaHook TcM)-  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool-                                         -> HomePackageTable -> IO SuccessFlag)-  , runRnSpliceHook        :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))-  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type-                                                          -> IO (Maybe HValue))-  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)-  , stgToCmmHook           :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)-  , cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a-                                 -> IO (Stream IO RawCmmGroup a))+               !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))+  , ghcPrimIfaceHook       :: !(Maybe ModIface)+  , runPhaseHook           :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)))+  , runMetaHook            :: !(Maybe (MetaHook TcM))+  , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool+                                         -> HomePackageTable -> IO SuccessFlag))+  , runRnSpliceHook        :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))+  , getValueSafelyHook     :: !(Maybe (HscEnv -> Name -> Type+                                                          -> IO (Maybe HValue)))+  , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))+  , stgToCmmHook           :: !(Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a+                                 -> IO (Stream IO RawCmmGroup a)))   } -getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a-getHooked hook def = fmap (lookupHook hook def) getDynFlags+class HasHooks m where+    getHooks :: m Hooks -lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a-lookupHook hook def = fromMaybe def . hook . hooks+class ContainsHooks a where+    extractHooks :: a -> Hooks

@@ -5,3 +5,9 @@ data Hooks  emptyHooks :: Hooks++class HasHooks m where+    getHooks :: m Hooks++class ContainsHooks a where+    extractHooks :: a -> Hooks

@@ -19,6 +19,14 @@         Session(..), withSession, modifySession, modifySessionM,         withTempSession, +        -- * Logger+        modifyLogger,+        pushLogHookM,+        popLogHookM,+        putLogMsgM,+        putMsgM,+        withTimingM,+         -- ** Warnings         logWarnings, printException,         WarnErrLogger, defaultWarnErrLogger@@ -33,7 +41,9 @@ import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Error+import GHC.Utils.Logger +import GHC.Types.SrcLoc import GHC.Types.SourceError  import Control.Monad@@ -57,7 +67,7 @@ -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. ---class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where+class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where   getSession :: m HscEnv   setSession :: HscEnv -> m () @@ -92,13 +102,52 @@ withTempSession f m =   withSavedSession $ modifySession f >> m +----------------------------------------+-- Logging+----------------------------------------++-- | Modify the logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+modifyLogger f = modifySession $ \hsc_env ->+    hsc_env { hsc_logger = f (hsc_logger hsc_env) }++-- | Push a log hook on the stack+pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()+pushLogHookM = modifyLogger . pushLogHook++-- | Pop a log hook from the stack+popLogHookM :: GhcMonad m => m ()+popLogHookM  = modifyLogger popLogHook++-- | Put a log message+putMsgM :: GhcMonad m => SDoc -> m ()+putMsgM doc = do+    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putMsg logger dflags doc++-- | Put a log message+putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()+putLogMsgM reason sev loc doc = do+    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putLogMsg logger dflags reason sev loc doc++-- | Time an action+withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b+withTimingM doc force action = do+    logger <- getLogger+    dflags <- getDynFlags+    withTiming logger dflags doc force action+ -- ----------------------------------------------------------------------------- -- | A monad that allows logging of warnings.  logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do   dflags <- getSessionDynFlags-  liftIO $ printOrThrowWarnings dflags warns+  logger <- getLogger+  liftIO $ printOrThrowWarnings logger dflags warns  -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,@@ -130,6 +179,9 @@ instance HasDynFlags Ghc where   getDynFlags = getSessionDynFlags +instance HasLogger Ghc where+  getLogger = hsc_logger <$> getSession+ instance GhcMonad Ghc where   getSession = Ghc $ \(Session r) -> readIORef r   setSession s' = Ghc $ \(Session r) -> writeIORef r s'@@ -180,6 +232,9 @@ instance MonadIO m => HasDynFlags (GhcT m) where   getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) +instance MonadIO m => HasLogger (GhcT m) where+  getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r)+ instance ExceptionMonad m => GhcMonad (GhcT m) where   getSession = GhcT $ \(Session r) -> liftIO $ readIORef r   setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'@@ -190,7 +245,8 @@ printException :: GhcMonad m => SourceError -> m () printException err = do   dflags <- getSessionDynFlags-  liftIO $ printBagOfErrors dflags (srcErrorMessages err)+  logger <- getLogger+  liftIO $ printBagOfErrors logger dflags (srcErrorMessages err)  -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()

@@ -15,6 +15,7 @@  import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Logger  import GHC.Driver.Session import GHC.Driver.Phases@@ -117,6 +118,9 @@  instance HasDynFlags CompPipeline where     getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))++instance HasLogger CompPipeline where+    getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state))  setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state ->

@@ -25,7 +25,7 @@         WarningFlag(..), WarnReason(..),         Language(..),         PlatformConstants(..),-        FatalMessager, LogAction, FlushOut(..), FlushErr(..),+        FatalMessager, FlushOut(..), FlushErr(..),         ProfAuto(..),         glasgowExtsFlags,         warningGroups, warningHierarchies,@@ -36,6 +36,8 @@         wopt_fatal, wopt_set_fatal, wopt_unset_fatal,         xopt, xopt_set, xopt_unset,         xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,         lang_set,         DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,         dynamicOutputFile,@@ -61,12 +63,11 @@         optimisationFlags,         setFlagsFromEnvFile,         pprDynFlagsDiff,+        flagSpecOf,+        smallestGroups,          targetProfile, -        -- ** Log output-        putLogMsg,-         -- ** Safe Haskell         safeHaskellOn, safeHaskellModeEnabled,         safeImportsOn, safeLanguageOn, safeInferOn,@@ -151,9 +152,6 @@         defaultWays,         initDynFlags,                   -- DynFlags -> IO DynFlags         defaultFatalMessager,-        defaultLogAction,-        defaultLogActionHPrintDoc,-        defaultLogActionHPutStrDoc,         defaultFlushOut,         defaultFlushErr, @@ -234,7 +232,6 @@ import GHC.Unit.Parser import GHC.Unit.Module import GHC.Builtin.Names ( mAIN_NAME )-import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Backend@@ -250,10 +247,10 @@ import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad-import qualified GHC.Utils.Ppr as Pretty import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )+import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString import GHC.Utils.Fingerprint import GHC.Utils.Outputable@@ -261,11 +258,6 @@ import GHC.CmmToAsm.CFG.Weight import {-# SOURCE #-} GHC.Core.Opt.CallerCC -import GHC.Types.Error-import {-# SOURCE #-} GHC.Utils.Error-                               ( DumpAction, TraceAction-                               , defaultDumpAction, defaultTraceAction )-import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -559,9 +551,6 @@     -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*     -- order that they're specified on the command line. -  -- GHC API hooks-  hooks                 :: Hooks,-   --  For ghc -M   depMakefile           :: FilePath,   depIncludePkgDeps     :: Bool,@@ -600,11 +589,6 @@   -- The next available suffix to uniquely name a temp file, updated atomically   nextTempSuffix        :: IORef Int, -  -- Names of files which were generated from -ddump-to-file; used to-  -- track which ones we need to truncate because it's our first run-  -- through-  generatedDumps        :: IORef (Set FilePath),-   -- hsc dynamic flags   dumpFlags             :: EnumSet DumpFlag,   generalFlags          :: EnumSet GeneralFlag,@@ -646,10 +630,6 @@    ghciHistSize          :: Int, -  -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can-  log_action            :: LogAction,-  dump_action           :: DumpAction,-  trace_action          :: TraceAction,   flushOut              :: FlushOut,   flushErr              :: FlushErr, @@ -884,7 +864,7 @@ versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath versionedAppDir appname platform = do   -- Make sure we handle the case the HOME isn't set (see #11678)-  appdir <- tryMaybeT $ getAppUserDataDirectory appname+  appdir <- tryMaybeT $ getXdgDirectory XdgData appname   return $ appdir </> versionedFilePath platform  versionedFilePath :: ArchOS -> FilePath@@ -1085,7 +1065,6 @@  refNextTempSuffix <- newIORef 0  refFilesToClean <- newIORef emptyFilesToClean  refDirsToClean <- newIORef Map.empty- refGeneratedDumps <- newIORef Set.empty  refRtldInfo <- newIORef Nothing  refRtccInfo <- newIORef Nothing  wrapperNum <- newIORef emptyModuleEnv@@ -1109,7 +1088,6 @@         nextTempSuffix = refNextTempSuffix,         filesToClean   = refFilesToClean,         dirsToClean    = refDirsToClean,-        generatedDumps = refGeneratedDumps,         nextWrapperNum = wrapperNum,         useUnicode    = useUnicode',         useColor      = useColor',@@ -1191,7 +1169,6 @@         pluginModNames          = [],         pluginModNameOpts       = [],         frontendPluginOpts      = [],-        hooks                   = emptyHooks,          outputFile_             = Nothing,         dynOutputFile_          = Nothing,@@ -1239,7 +1216,6 @@         nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",         filesToClean   = panic "defaultDynFlags: No filesToClean",         dirsToClean    = panic "defaultDynFlags: No dirsToClean",-        generatedDumps = panic "defaultDynFlags: No generatedDumps",         ghcVersionFile = Nothing,         haddockOptions = Nothing,         dumpFlags = EnumSet.empty,@@ -1267,12 +1243,6 @@          ghciHistSize = 50, -- keep a log of length 50 by default -        -- Logging--        log_action   = defaultLogAction,-        dump_action  = defaultDumpAction,-        trace_action = defaultTraceAction,-         flushOut = defaultFlushOut,         flushErr = defaultFlushErr,         pprUserLength = 5,@@ -1313,119 +1283,13 @@                        then Set.singleton WayDyn                        else Set.empty --------------------------------------------------------------------------------- Note [JSON Error Messages]------ When the user requests the compiler output to be dumped as json--- we used to collect them all in an IORef and then print them at the end.--- This doesn't work very well with GHCi. (See #14078) So instead we now--- use the simpler method of just outputting a JSON document inplace to--- stdout.------ Before the compiler calls log_action, it has already turned the `ErrMsg`--- into a formatted message. This means that we lose some possible--- information to provide to the user but refactoring log_action is quite--- invasive as it is called in many places. So, for now I left it alone--- and we can refine its behaviour as users request different output.  type FatalMessager = String -> IO () -type LogAction = DynFlags-              -> WarnReason-              -> Severity-              -> SrcSpan-              -> MsgDoc-              -> IO ()- defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr  --- See Note [JSON Error Messages]----jsonLogAction :: LogAction-jsonLogAction dflags reason severity srcSpan msg-  =-    defaultLogActionHPutStrDoc dflags True stdout-      (withPprStyle (PprCode CStyle) (doc $$ text ""))-    where-      str = renderWithContext (initSDocContext dflags defaultUserStyle) msg-      doc = renderJSON $-              JSObject [ ( "span", json srcSpan )-                       , ( "doc" , JSString str )-                       , ( "severity", json severity )-                       , ( "reason" ,   json reason )-                       ]---defaultLogAction :: LogAction-defaultLogAction dflags reason severity srcSpan msg-    = case severity of-      SevOutput      -> printOut msg-      SevDump        -> printOut (msg $$ blankLine)-      SevInteractive -> putStrSDoc msg-      SevInfo        -> printErrs msg-      SevFatal       -> printErrs msg-      SevWarning     -> printWarns-      SevError       -> printWarns-    where-      printOut   = defaultLogActionHPrintDoc  dflags False stdout-      printErrs  = defaultLogActionHPrintDoc  dflags False stderr-      putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout-      -- Pretty print the warning flag, if any (#10752)-      message = mkLocMessageAnn flagMsg severity srcSpan msg--      printWarns = do-        hPutChar stderr '\n'-        caretDiagnostic <--            if gopt Opt_DiagnosticsShowCaret dflags-            then getCaretDiagnostic severity srcSpan-            else pure empty-        printErrs $ getPprStyle $ \style ->-          withPprStyle (setStyleColoured True style)-            (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 =-        case reason of-          NoReason -> Nothing-          Reason wflag -> do-            spec <- flagSpecOf wflag-            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)-          ErrReason Nothing ->-            return "-Werror"-          ErrReason (Just wflag) -> do-            spec <- flagSpecOf wflag-            return $-              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++-              ", -Werror=" ++ flagSpecName spec--      warnFlagGrp flag-          | gopt Opt_ShowWarnGroups dflags =-                case smallestGroups flag of-                    [] -> ""-                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"-          | otherwise = ""---- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.-defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()-defaultLogActionHPrintDoc dflags asciiSpace h d- = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")---- | The boolean arguments let's the pretty printer know if it can optimize indent--- by writing ascii ' ' characters without going through decoding.-defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()-defaultLogActionHPutStrDoc dflags asciiSpace h d-  -- Don't add a newline at the end, so that successive-  -- calls to this log-action can output all on the same line-  = printSDoc ctx (Pretty.PageMode asciiSpace) h d-    where-      ctx = initSDocContext dflags defaultUserStyle- newtype FlushOut = FlushOut (IO ())  defaultFlushOut :: FlushOut@@ -1477,8 +1341,6 @@    -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html       (languageExtensions (Just Haskell2010)) -   -- NB: MonoPatBinds is no longer the default- languageExtensions (Just Haskell98)     = [LangExt.ImplicitPrelude,        -- See Note [When is StarIsType enabled]@@ -1488,6 +1350,7 @@        LangExt.NPlusKPatterns,        LangExt.DatatypeContexts,        LangExt.TraditionalRecordSyntax,+       LangExt.FieldSelectors,        LangExt.NondecreasingIndentation            -- strictly speaking non-standard, but we always had this            -- on implicitly before the option was added in 7.1, and@@ -1508,6 +1371,7 @@        LangExt.ForeignFunctionInterface,        LangExt.PatternGuards,        LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,        LangExt.RelaxedPolyRec]  hasPprDebug :: DynFlags -> Bool@@ -1644,6 +1508,16 @@     in         if ext `elem` referedExts then dflags else setUnset dflags ext +xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields+xopt_DuplicateRecordFields dfs+  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields+  | otherwise                              = FieldLabel.NoDuplicateRecordFields++xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors+xopt_FieldSelectors dfs+  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors+  | otherwise                       = FieldLabel.NoFieldSelectors+ lang_set :: DynFlags -> Maybe Language -> DynFlags lang_set dflags lang =    dflags {@@ -1794,9 +1668,6 @@ setDynOutputFile f d = d { dynOutputFile_ = f} setOutputHi      f d = d { outputHi       = f} -setJsonLogAction :: DynFlags -> DynFlags-setJsonLogAction d = d { log_action = jsonLogAction }- parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of     [(r, "")] -> r@@ -1980,10 +1851,6 @@    return (dflags4, leftover, warns' ++ warns) --- | Write an error or warning to the 'LogOutput'.-putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()-putLogMsg dflags = log_action dflags dflags- -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. --@@ -2004,10 +1871,9 @@            ++ str]  safeFlagCheck cmdl dflags =-  case (safeInferOn dflags) of-    True | safeFlags -> (dflags', warn)-    True             -> (dflags' { safeInferred = False }, warn)-    False            -> (dflags', warn)+  case safeInferOn dflags of+    True   -> (dflags' { safeInferred = safeFlags }, warn)+    False  -> (dflags', warn)    where     -- dynflags and warn for when -fpackage-trust by itself with no safe@@ -2649,7 +2515,7 @@   , make_ord_flag defGhcFlag "ddump-debug"         (setDumpFlag Opt_D_dump_debug)   , make_ord_flag defGhcFlag "ddump-json"-        (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )+        (setDumpFlag Opt_D_dump_json )   , make_ord_flag defGhcFlag "dppr-debug"         (setDumpFlag Opt_D_ppr_debug)   , make_ord_flag defGhcFlag "ddebug-output"@@ -2846,6 +2712,11 @@   , make_ord_flag defFlag "funfolding-dict-discount"       (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)})) +  , make_ord_flag defFlag "funfolding-case-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-case-scaling"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))+   , make_dep_flag defFlag "funfolding-keeness-factor"       (floatSuffix (\_ d -> d))       "-funfolding-keeness-factor is no longer respected as of GHC 9.0"@@ -2981,14 +2852,6 @@  ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps  ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps  ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps- ++ [ make_dep_flag defFlag "XGenerics"-        (NoArg $ return ())-                  ("it does nothing; look into -XDefaultSignatures " ++-                   "and -XDeriveGeneric for generic programming support.")-    , make_dep_flag defFlag "XNoGenerics"-        (NoArg $ return ())-               ("it does nothing; look into -XDefaultSignatures and " ++-                  "-XDeriveGeneric for generic programming support.") ]  -- | This is where we handle unrecognised warning flags. We only issue a warning -- if -Wunrecognised-warning-flags is set. See #11429 for context.@@ -3193,6 +3056,7 @@ -- Please keep the list of flags below sorted alphabetically   flagSpec "alternative-layout-rule-transitional"                                       Opt_WarnAlternativeLayoutRuleTransitional,+  flagSpec "ambiguous-fields"            Opt_WarnAmbiguousFields,   depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans     "it has no effect",   flagSpec "cpp-undef"                   Opt_WarnCPPUndef,@@ -3509,8 +3373,6 @@     (deprecatedForExtension "BangPatterns"),   depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction     (deprecatedForExtension "MonomorphismRestriction"),-  depFlagSpec' "mono-pat-binds"                 LangExt.MonoPatBinds-    (deprecatedForExtension "MonoPatBinds"),   depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules     (deprecatedForExtension "ExtendedDefaultRules"),   depFlagSpec' "implicit-params"                LangExt.ImplicitParams@@ -3612,6 +3474,7 @@   depFlagSpec' "DoRec"                        LangExt.RecursiveDo     (deprecatedForExtension "RecursiveDo"),   flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,+  flagSpec "FieldSelectors"                   LangExt.FieldSelectors,   flagSpec "EmptyCase"                        LangExt.EmptyCase,   flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,   flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,@@ -3649,9 +3512,6 @@   flagSpec "MagicHash"                        LangExt.MagicHash,   flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,   flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,-  depFlagSpecCond "MonoPatBinds"              LangExt.MonoPatBinds-    id-         "Experimental feature now removed; has no effect",   flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,   flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,   flagSpec "MultiWayIf"                       LangExt.MultiWayIf,@@ -4051,6 +3911,7 @@         Opt_WarnDerivingDefaults,         Opt_WarnOverflowedLiterals,         Opt_WarnEmptyEnumerations,+        Opt_WarnAmbiguousFields,         Opt_WarnMissingFields,         Opt_WarnMissingMethods,         Opt_WarnWrongDoBind,

@@ -66,14 +66,13 @@ import qualified Data.Data as Data (Fixity(..)) import qualified Data.Kind import Data.Maybe (isJust)+import Data.Void  ( Void ) -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Expressions proper}+                Expressions proper *                                                                      *-************************************************************************--}+********************************************************************* -}  -- | Post-Type checking Expression --@@ -191,10 +190,21 @@  -- --------------------------------------------------------------------- +{- Note [Constructor cannot occur]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some data constructors can't occur in certain phases; e.g. the output+of the type checker never has OverLabel. We signal this by setting+the extension field to Void. For example:+   type instance XOverLabel GhcTc = Void+   dsExpr (HsOverLabel x _) = absurd x++It would be better to omit the pattern match altogether, but we+could only do that if the extension field was strict (#18764)+-}+ type instance XVar           (GhcPass _) = NoExtField type instance XConLikeOut    (GhcPass _) = NoExtField type instance XRecFld        (GhcPass _) = NoExtField-type instance XOverLabel     (GhcPass _) = NoExtField type instance XIPVar         (GhcPass _) = NoExtField type instance XOverLitE      (GhcPass _) = NoExtField type instance XLitE          (GhcPass _) = NoExtField@@ -202,6 +212,12 @@ type instance XLamCase       (GhcPass _) = NoExtField type instance XApp           (GhcPass _) = NoExtField +-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOverLabel     GhcPs = NoExtField+type instance XOverLabel     GhcRn = NoExtField+type instance XOverLabel     GhcTc = Void  -- See Note [Constructor cannot occur]+ type instance XUnboundVar    GhcPs = NoExtField type instance XUnboundVar    GhcRn = NoExtField type instance XUnboundVar    GhcTc = HoleExprRef@@ -214,14 +230,24 @@ type instance XAppTypeE      GhcRn = NoExtField type instance XAppTypeE      GhcTc = Type +-- OpApp not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs] type instance XOpApp         GhcPs = NoExtField type instance XOpApp         GhcRn = Fixity-type instance XOpApp         GhcTc = Fixity+type instance XOpApp         GhcTc = Void  -- See Note [Constructor cannot occur] +-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XSectionL      GhcPs = NoExtField+type instance XSectionR      GhcPs = NoExtField+type instance XSectionL      GhcRn = NoExtField+type instance XSectionR      GhcRn = NoExtField+type instance XSectionL      GhcTc = Void  -- See Note [Constructor cannot occur]+type instance XSectionR      GhcTc = Void  -- See Note [Constructor cannot occur]++ type instance XNegApp        (GhcPass _) = NoExtField type instance XPar           (GhcPass _) = NoExtField-type instance XSectionL      (GhcPass _) = NoExtField-type instance XSectionR      (GhcPass _) = NoExtField type instance XExplicitTuple (GhcPass _) = NoExtField  type instance XExplicitSum   GhcPs = NoExtField@@ -245,6 +271,13 @@ type instance XExplicitList  GhcPs = NoExtField type instance XExplicitList  GhcRn = NoExtField type instance XExplicitList  GhcTc = Type+-- GhcPs: ExplicitList includes all source-level+--   list literals, including overloaded ones+-- GhcRn and GhcTc: ExplicitList used only for list literals+--   that denote Haskell's built-in lists.  Overloaded lists+--   have been expanded away in the renamer+-- See Note [Handling overloaded and rebindable constructs]+-- in  GHC.Rename.Expr  type instance XRecordCon     GhcPs = NoExtField type instance XRecordCon     GhcRn = NoExtField@@ -288,8 +321,6 @@   = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)   | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)) -- -- ---------------------------------------------------------------------  type instance XSCC           (GhcPass _) = NoExtField@@ -346,7 +377,7 @@ ppr_expr (HsConLikeOut _ c)  = pprPrefixOcc c ppr_expr (HsRecFld _ f)      = pprPrefixOcc f ppr_expr (HsIPVar _ v)       = ppr v-ppr_expr (HsOverLabel _ _ l) = char '#' <> ppr l+ppr_expr (HsOverLabel _ l)   = char '#' <> ppr l ppr_expr (HsLit _ lit)       = ppr lit ppr_expr (HsOverLit _ lit)   = ppr lit ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)@@ -465,7 +496,7 @@  ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts -ppr_expr (ExplicitList _ _ exprs)+ppr_expr (ExplicitList _ exprs)   = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))  ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })@@ -676,6 +707,139 @@      -- no doublequotes if stl empty, for the case where the SCC was written      -- without quotes.     <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"+++{- *********************************************************************+*                                                                      *+             HsExpansion and rebindable syntax+*                                                                      *+********************************************************************* -}++{- Note [Rebindable syntax and HsExpansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We implement rebindable syntax (RS) support by performing a desugaring+in the renamer. We transform GhcPs expressions affected by RS into the+appropriate desugared form, but **annotated with the original expression**.++Let us consider a piece of code like:++    {-# LANGUAGE RebindableSyntax #-}+    ifThenElse :: Char -> () -> () -> ()+    ifThenElse _ _ _ = ()+    x = if 'a' then () else True++The parsed AST for the RHS of x would look something like (slightly simplified):++    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))++Upon seeing such an AST with RS on, we could transform it into a+mere function call, as per the RS rules, equivalent to the+following function application:++    ifThenElse 'a' () True++which doesn't typecheck. But GHC would report an error about+not being able to match the third argument's type (Bool) with the+expected type: (), in the expression _as desugared_, i.e in+the aforementioned function application. But the user never+wrote a function application! This would be pretty bad.++To remedy this, instead of transforming the original HsIf+node into mere applications of 'ifThenElse', we keep the+original 'if' expression around too, using the TTG+XExpr extension point to allow GHC to construct an+'HsExpansion' value that will keep track of the original+expression in its first field, and the desugared one in the+second field. The resulting renamed AST would look like:++    L locif (XExpr+      (HsExpanded+        (HsIf (L loca 'a')+              (L loctrue ())+              (L locfalse True)+        )+        (App (L generatedSrcSpan+                (App (L generatedSrcSpan+                        (App (L generatedSrcSpan (Var ifThenElse))+                             (L loca 'a')+                        )+                     )+                     (L loctrue ())+                )+             )+             (L locfalse True)+        )+      )+    )++When comes the time to typecheck the program, we end up calling+tcMonoExpr on the AST above. If this expression gives rise to+a type error, then it will appear in a context line and GHC+will pretty-print it using the 'Outputable (HsExpansion a b)'+instance defined below, which *only prints the original+expression*. This is the gist of the idea, but is not quite+enough to recover the error messages that we had with the+SyntaxExpr-based, typechecking/desugaring-to-core time+implementation of rebindable syntax. The key idea is to decorate+some elements of the desugared expression so as to be able to+give them a special treatment when typechecking the desugared+expression, to print a different context line or skip one+altogether.++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we+entered generated code, i.e code fabricated by the compiler when rebinding some+syntax. If someone tries to push some error context line while that field is set+to True, the pushing won't actually happen and the context line is just dropped.+Once we 'setSrcSpan' a real span (for an expression that was in the original+source code), we set 'tcl_in_gen_code' back to False, indicating that we+"emerged from the generated code tunnel", and that the expressions we will be+processing are relevant to report in context lines again.++You might wonder why TcLclEnv has both+   tcl_loc         :: RealSrcSpan+   tcl_in_gen_code :: Bool+Could we not store a Maybe RealSrcSpan? The problem is that we still+generate constraints when processing generated code, and a CtLoc must+contain a RealSrcSpan -- otherwise, error messages might appear+without source locations. So tcl_loc keeps the RealSrcSpan of the last+location spotted that wasn't generated; it's as good as we're going to+get in generated code. Once we get to sub-trees that are not+generated, then we update the RealSrcSpan appropriately, and set the+tcl_in_gen_code Bool to False.++---++A general recipe to follow this approach for new constructs could go as follows:++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your+  construct, in HsExpr or related syntax data types.+- At renaming-time:+    - take your original node of interest (HsIf above)+    - rename its subexpressions (condition, true branch, false branch above)+    - construct the suitable "rebound"-and-renamed result (ifThenElse call+      above), where the 'SrcSpan' attached to any _fabricated node_ (the+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'+    - take both the original node and that rebound-and-renamed result and wrap+      them in an XExpr: XExpr (HsExpanded <original node> <desugared>)+ - At typechecking-time:+    - remove any logic that was previously dealing with your rebindable+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.+    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we+      typecheck the desugared expression while reporting the original one in+      errors++-}++-- See Note [Rebindable syntax and HsExpansion] just above.+data HsExpansion a b+  = HsExpanded a b+  deriving Data++-- | Just print the original expression (the @a@).+instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where+  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)+  {- ************************************************************************

@@ -62,6 +62,7 @@    -- * Literals   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,+  mkHsCharPrimLit,    -- * Patterns   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,@@ -412,7 +413,10 @@ mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) +mkHsCharPrimLit :: Char -> HsLit (GhcPass p)+mkHsCharPrimLit c = HsChar NoSourceText c + {- ************************************************************************ *                                                                      *@@ -541,7 +545,7 @@  nlHsCase expr matches   = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))-nlList exprs          = noLoc (ExplicitList noExtField Nothing exprs)+nlList exprs          = noLoc (ExplicitList noExtField exprs)  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)

@@ -190,6 +190,7 @@ data IfaceTyLit   = IfaceNumTyLit Integer   | IfaceStrTyLit FastString+  | IfaceCharTyLit Char   deriving (Eq)  type IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis@@ -1418,8 +1419,10 @@        , 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_ty appPrec) $-          appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args)+       -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $+          appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args)+          -- Use appArgsIfaceTypesArgFlags to print invisible arguments+          -- correctly (#19310)         | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey        , not debug@@ -1619,6 +1622,7 @@ pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n)+pprIfaceTyLit (IfaceCharTyLit c) = text (show c)  pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co topPrec@@ -1766,8 +1770,9 @@   ppr = pprIfaceTyLit  instance Binary IfaceTyLit where-  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n-  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n+  put_ bh (IfaceNumTyLit n)   = putByte bh 1 >> put_ bh n+  put_ bh (IfaceStrTyLit n)   = putByte bh 2 >> put_ bh n+  put_ bh (IfaceCharTyLit n)  = putByte bh 3 >> put_ bh n    get bh =     do tag <- getByte bh@@ -1776,6 +1781,8 @@                  ; return (IfaceNumTyLit n) }          2 -> do { n <- get bh                  ; return (IfaceStrTyLit n) }+         3 -> do { n <- get bh+                 ; return (IfaceCharTyLit n) }          _ -> panic ("get IfaceTyLit " ++ show tag)  instance Binary IfaceAppArgs where@@ -2108,6 +2115,7 @@   rnf = \case     IfaceNumTyLit f1 -> rnf f1     IfaceStrTyLit f1 -> rnf f1+    IfaceCharTyLit f1 -> rnf f1  instance NFData IfaceCoercion where   rnf = \case

@@ -36,8 +36,8 @@       -- | Warn when tabulations are found    = PsWarnTab-      { tabFirst :: !SrcSpan -- ^ First occurence of a tab-      , tabCount :: !Word    -- ^ Number of other occurences+      { tabFirst :: !SrcSpan -- ^ First occurrence of a tab+      , tabCount :: !Word    -- ^ Number of other occurrences       }     | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason@@ -53,7 +53,7 @@       -- ^ Multiple Haddock comment for the same entity     | PsWarnStarBinder !SrcSpan-      -- ^ Found binding occurence of "*" while StarIsType is enabled+      -- ^ Found binding occurrence of "*" while StarIsType is enabled     | PsWarnStarIsType !SrcSpan       -- ^ Using "*" for "Type" without StarIsType enabled@@ -103,7 +103,7 @@       -- ^ Lexer error     | PsErrSuffixAT-      -- ^ Suffix occurence of `@`+      -- ^ Suffix occurrence of `@`     | PsErrParse !String       -- ^ Parse errors

@@ -24,25 +24,25 @@ import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -mkParserErr :: SrcSpan -> SDoc -> ErrMsg ErrDoc-mkParserErr span doc = ErrMsg+mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc+mkParserErr span doc = MsgEnvelope    { errMsgSpan        = span    , errMsgContext     = alwaysQualify-   , errMsgDiagnostic  = ErrDoc [doc] [] []+   , errMsgDiagnostic  = mkDecorated [doc]    , errMsgSeverity    = SevError    , errMsgReason      = NoReason    } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg ErrDoc-mkParserWarn flag span doc = ErrMsg+mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc+mkParserWarn flag span doc = MsgEnvelope    { errMsgSpan        = span    , errMsgContext     = alwaysQualify-   , errMsgDiagnostic  = ErrDoc [doc] [] []+   , errMsgDiagnostic  = mkDecorated [doc]    , errMsgSeverity    = SevWarning    , errMsgReason      = Reason flag    } -pprWarning :: PsWarning -> ErrMsg ErrDoc+pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = \case    PsWarnTab loc tc       -> mkParserWarn Opt_WarnTabs loc $@@ -128,7 +128,7 @@            OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"            OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> ErrMsg ErrDoc+pprError :: PsError -> MsgEnvelope DecoratedSDoc pprError err = mkParserErr (errLoc err) $ vcat    (pp_err (errDesc err) : map pp_hint (errHints err)) 

@@ -313,7 +313,7 @@   = when (notNull flags) $       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags     where mkMsg (L loc flag)-              = mkPlainErrMsg loc $+              = mkPlainMsgEnvelope loc $                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>                    text flag) @@ -348,7 +348,7 @@      suggestions = fuzzyMatch unsup supported  -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages ErrDoc+optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc optionsErrorMsgs unhandled_flags flags_lines _filename   = mkMessages $ listToBag (map mkMsg unhandled_flags_lines)   where unhandled_flags_lines :: [Located String]@@ -357,7 +357,7 @@                                 , L l f' <- flags_lines                                 , f == f' ]         mkMsg (L flagSpan flag) =-            mkPlainErrMsg flagSpan $+            mkPlainMsgEnvelope flagSpan $                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag  optionsParseError :: String -> SrcSpan -> a     -- #15053@@ -370,4 +370,4 @@  throwErr :: SrcSpan -> SDoc -> a                -- #15053 throwErr loc doc =-  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg loc doc+  throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc

@@ -1482,7 +1482,7 @@   mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)   mkHsWildCardPV l = return $ L l hsHoleExpr   mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig))-  mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)+  mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs)   mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp   mkHsRecordPV l lrec a (fbinds, ddLoc) = do     r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)

@@ -110,7 +110,7 @@ We search for comments after  HsTyVar "Int"  and until the next syntactic element, in this case  HsTyVar "Bool". -Ignoring the "->" allows us to accomodate alternative coding styles:+Ignoring the "->" allows us to accommodate alternative coding styles:    f :: Int ->   -- ^ comment on argument        Bool     -- ^ comment on result@@ -1540,7 +1540,7 @@ and sometimes it simply made it hard to modify and extend the grammar.  Another issue was that sometimes Haddock would fail to parse code-that GHC could parse succesfully:+that GHC could parse successfully:    class BadIndent where     f :: a -> Int

@@ -12,6 +12,7 @@ import GHC.Driver.Session import GHC.Utils.Error import GHC.Utils.Outputable+import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Exception as Exception import GHC.Driver.Phases@@ -40,17 +41,17 @@   -- runGhc(T)   deriving (Show) -cleanTempDirs :: DynFlags -> IO ()-cleanTempDirs dflags+cleanTempDirs :: Logger -> DynFlags -> IO ()+cleanTempDirs logger dflags    = unless (gopt Opt_KeepTmpFiles dflags)    $ mask_    $ do let ref = dirsToClean dflags         ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)-        removeTmpDirs dflags (Map.elems ds)+        removeTmpDirs logger dflags (Map.elems ds)  -- | Delete all files in @filesToClean dflags@.-cleanTempFiles :: DynFlags -> IO ()-cleanTempFiles dflags+cleanTempFiles :: Logger -> DynFlags -> IO ()+cleanTempFiles logger dflags    = unless (gopt Opt_KeepTmpFiles dflags)    $ mask_    $ do let ref = filesToClean dflags@@ -60,21 +61,21 @@                 , ftcGhcSession = gs_files                 } -> ( emptyFilesToClean                      , Set.toList cm_files ++ Set.toList gs_files)-        removeTmpFiles dflags to_delete+        removeTmpFiles logger dflags to_delete  -- | Delete all files in @filesToClean dflags@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.-cleanCurrentModuleTempFiles :: DynFlags -> IO ()-cleanCurrentModuleTempFiles dflags+cleanCurrentModuleTempFiles :: Logger -> DynFlags -> IO ()+cleanCurrentModuleTempFiles logger dflags    = unless (gopt Opt_KeepTmpFiles dflags)    $ mask_    $ do let ref = filesToClean dflags         to_delete <- atomicModifyIORef' ref $             \ftc@FilesToClean{ftcCurrentModule = cm_files} ->                 (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)-        removeTmpFiles dflags to_delete+        removeTmpFiles logger dflags to_delete  -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.@@ -117,9 +118,9 @@   atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)  -- Find a temporary name that doesn't already exist.-newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath-newTempName dflags lifetime extn-  = do d <- getTempDir dflags+newTempName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath+newTempName logger dflags lifetime extn+  = do d <- getTempDir logger dflags        findTempName (d </> "ghc_") -- See Note [Deterministic base name]   where     findTempName :: FilePath -> IO FilePath@@ -132,9 +133,9 @@                         addFilesToClean dflags lifetime [filename]                         return filename -newTempDir :: DynFlags -> IO FilePath-newTempDir dflags-  = do d <- getTempDir dflags+newTempDir :: Logger -> DynFlags -> IO FilePath+newTempDir logger dflags+  = do d <- getTempDir logger dflags        findTempDir (d </> "ghc_")   where     findTempDir :: FilePath -> IO FilePath@@ -147,10 +148,10 @@                         -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename                         return filename -newTempLibName :: DynFlags -> TempFileLifetime -> Suffix+newTempLibName :: Logger -> DynFlags -> TempFileLifetime -> Suffix   -> IO (FilePath, FilePath, String)-newTempLibName dflags lifetime extn-  = do d <- getTempDir dflags+newTempLibName logger dflags lifetime extn+  = do d <- getTempDir logger dflags        findTempName d ("ghc_")   where     findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)@@ -167,8 +168,8 @@  -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet.-getTempDir :: DynFlags -> IO FilePath-getTempDir dflags = do+getTempDir :: Logger -> DynFlags -> IO FilePath+getTempDir logger dflags = do     mapping <- readIORef dir_ref     case Map.lookup tmp_dir mapping of         Nothing -> do@@ -199,7 +200,7 @@         -- directory we created.  Otherwise return the directory we created.         case their_dir of             Nothing  -> do-                debugTraceMsg dflags 2 $+                debugTraceMsg logger dflags 2 $                     text "Created temporary directory:" <+> text our_dir                 return our_dir             Just dir -> do@@ -219,18 +220,18 @@  This is ok, as the temporary directory used contains the pid (see getTempDir). -}-removeTmpDirs :: DynFlags -> [FilePath] -> IO ()-removeTmpDirs dflags ds-  = traceCmd dflags "Deleting temp dirs"+removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO ()+removeTmpDirs logger dflags ds+  = traceCmd logger dflags "Deleting temp dirs"              ("Deleting: " ++ unwords ds)-             (mapM_ (removeWith dflags removeDirectory) ds)+             (mapM_ (removeWith logger dflags removeDirectory) ds) -removeTmpFiles :: DynFlags -> [FilePath] -> IO ()-removeTmpFiles dflags fs+removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO ()+removeTmpFiles logger dflags fs   = warnNon $-    traceCmd dflags "Deleting temp files"+    traceCmd logger dflags "Deleting temp files"              ("Deleting: " ++ unwords deletees)-             (mapM_ (removeWith dflags removeFile) deletees)+             (mapM_ (removeWith logger dflags removeFile) deletees)   where      -- Flat out refuse to delete files that are likely to be source input      -- files (is there a worse bug than having a compiler delete your source@@ -241,21 +242,21 @@     warnNon act      | null non_deletees = act      | otherwise         = do-        putMsg dflags (text "WARNING - NOT deleting source files:"+        putMsg logger dflags (text "WARNING - NOT deleting source files:"                        <+> hsep (map text non_deletees))         act      (non_deletees, deletees) = partition isHaskellUserSrcFilename fs -removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()-removeWith dflags remover f = remover f `catchIO`+removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()+removeWith logger dflags remover f = remover f `catchIO`   (\e ->    let msg = if isDoesNotExistError e              then text "Warning: deleting non-existent" <+> text f              else text "Warning: exception raised when deleting"                                             <+> text f <> colon                $$ text (show e)-   in debugTraceMsg dflags 2 msg+   in debugTraceMsg logger dflags 2 msg   )  #if defined(mingw32_HOST_OS)

@@ -89,6 +89,7 @@  import GHC.Driver.Env import GHC.Driver.Session+import {-# SOURCE #-} GHC.Driver.Hooks  import GHC.Hs @@ -142,6 +143,7 @@ import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Logger  import GHC.Builtin.Names ( isUnboundName ) @@ -236,6 +238,12 @@ instance ContainsDynFlags (Env gbl lcl) where     extractDynFlags env = hsc_dflags (env_top env) +instance ContainsHooks (Env gbl lcl) where+    extractHooks env = hsc_hooks (env_top env)++instance ContainsLogger (Env gbl lcl) where+    extractLogger env = hsc_logger (env_top env)+ instance ContainsModule gbl => ContainsModule (Env gbl lcl) where     extractModule env = extractModule (env_gbl env) @@ -676,6 +684,9 @@           Coercible solver updates tcg_keep's TcRef whenever it           encounters a use of `coerce` that crosses newtype boundaries. +      (e) Record fields that are used to solve HasField constraints+          (see Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class)+       The tcg_keep field is used in two distinct ways:        * Desugar.addExportFlagsAndRules.  Where things like (a-c) are locally@@ -748,7 +759,7 @@                                       -- and for tidying types          tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints-        tcl_errs :: TcRef (Messages ErrDoc)     -- Place to accumulate errors+        tcl_errs :: TcRef (Messages DecoratedSDoc)     -- Place to accumulate errors     }  setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv@@ -763,7 +774,7 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))+type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))         -- Monadic so that we have a chance         -- to deal with bound type variables just before error         -- message construction@@ -1712,8 +1723,8 @@  -- | Check the 'TcGblEnv' for consistency. Currently, only checks -- axioms, but should check other aspects, too.-lintGblEnv :: DynFlags -> TcGblEnv -> TcM ()-lintGblEnv dflags tcg_env =-  liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms+lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM ()+lintGblEnv logger dflags tcg_env =+  liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms   where     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)

@@ -481,7 +481,8 @@ exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)-exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l+exprCtOrigin (HsOverLabel _ l)    = OverLabelOrigin l+exprCtOrigin (ExplicitList {})    = ListOrigin exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"@@ -501,7 +502,6 @@ exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e exprCtOrigin (HsDo {})           = DoOrigin-exprCtOrigin (ExplicitList {})   = Shouldn'tHappenOrigin "list" exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {})      = Shouldn'tHappenOrigin "record update" exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin

@@ -230,7 +230,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString-import GHC.Utils.Error( Validity(..), MsgDoc, isValid )+import GHC.Utils.Error( Validity(..), isValid ) import qualified GHC.LanguageExtensions as LangExt  import Data.List  ( mapAccumL )@@ -1171,6 +1171,7 @@ getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n)  -- hm+getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n)  {- ********************************************************************* *                                                                      *@@ -1521,8 +1522,8 @@ -- ^ tcEqType implements typechecker equality, as described in -- @Note [Typechecker equality vs definitional equality]@. tcEqType ty1 ty2-  =  tc_eq_type False False ki1 ki2-  && tc_eq_type False False ty1 ty2+  =  tcEqTypeNoSyns ki1 ki2+  && tcEqTypeNoSyns ty1 ty2   where     ki1 = tcTypeKind ty1     ki2 = tcTypeKind ty2@@ -1531,8 +1532,40 @@ -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: TcType -> TcType -> Bool tcEqTypeNoKindCheck ty1 ty2-  = tc_eq_type False False 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@@ -1545,16 +1578,6 @@ -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False 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- -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool          -- ^ True <=> do not expand type synonyms            -> Bool          -- ^ True <=> compare visible args only@@ -1647,6 +1670,7 @@           = go env w w' && go env arg arg' && go env res res'         get_args _ _    = False     eqFunTy _ _ _ _ _   = False+{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].  {- Note [Typechecker equality vs definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2432,7 +2456,7 @@   | otherwise   = NotValid unlifted_only -unlifted_only :: MsgDoc+unlifted_only :: SDoc unlifted_only = text "foreign import prim only accepts simple unlifted types"  validIfUnliftedFFITypes :: DynFlags -> Validity

@@ -96,13 +96,13 @@  gives rise to the AvailInfo -  AvailTC T [T, MkT, FieldLabel "foo" False foo]+  AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo]  whereas if -XDuplicateRecordFields is enabled it gives -  AvailTC T [T, MkT, FieldLabel "foo" True $sel:foo:MkT]+  AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] -since the label does not match the selector name.+where the label foo does not match the selector name $sel:foo:MkT.  The labels in a field list are not necessarily unique: data families allow the same parent (the family tycon) to have@@ -115,25 +115,25 @@ gives rise to    AvailTC F [ F, MkFInt, MkFBool-            , FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" True $sel:foo:MkFBool ]+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] -Moreover, note that the flIsOverloaded flag need not be the same for-all the elements of the list.  In the example above, this occurs if-the two data instances are defined in different modules, one with-`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it-is possible to have+Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags+need not be the same for all the elements of the list.  In the example above,+this occurs if the two data instances are defined in different modules, with+different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors`+extensions.  Thus it is possible to have    AvailTC F [ F, MkFInt, MkFBool-            , FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" False foo ]+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt+            , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] -If the two data instances are defined in different modules, both-without `-XDuplicateRecordFields`, it will be impossible to export-them from the same module (even with `-XDuplicateRecordfields`-enabled), because they would be represented identically.  The-workaround here is to enable `-XDuplicateRecordFields` on the defining-modules.+If the two data instances are defined in different modules, both without+`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to+export them from the same module (even with `-XDuplicateRecordfields` enabled),+because they would be represented identically.  The workaround here is to enable+`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules.  See+also #13352.   Note [Representing pattern synonym fields in AvailInfo]

@@ -26,7 +26,7 @@          ConTag, ConTagZ, fIRST_TAG, -        Arity, RepArity, JoinArity,+        Arity, RepArity, JoinArity, FullArgCount,          Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -172,6 +172,11 @@ -- are counted. type JoinArity = Int +-- | FullArgCount is the number of type or value arguments in an application,+-- or the number of type or value binders in a lambda.  Note: it includes+-- both type and value arguments!+type FullArgCount = Int+ {- ************************************************************************ *                                                                      *@@ -938,7 +943,7 @@ type BranchCount = Int   -- For OneOcc, the BranchCount says how many syntactic occurrences there are   -- At the moment we really only check for 1 or >1, but in principle-  --   we could pay attention to how *many* occurences there are+  --   we could pay attention to how *many* occurrences there are   --   (notably in postInlineUnconditionally).   -- But meanwhile, Ints are very efficiently represented. 

@@ -1046,7 +1046,31 @@     it's perfectly possible to enter the additional lambda and evaluate it     in unforeseen ways (so, not absent). +Note [Bottom CPR iff Dead-Ending Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both CPR analysis and Demand analysis handle recursive functions by doing+fixed-point iteration. To find the *least* (e.g., most informative) fixed-point,+iteration starts with the bottom element of the semantic domain. Diverging+functions generally have the bottom element as their least fixed-point. +One might think that CPR analysis and Demand analysis then agree in when a+function gets a bottom denotation. E.g., whenever it has 'botCpr', it should+also have 'botDiv'. But that is not the case, because strictness analysis has to+be careful around precise exceptions, see Note [Precise vs imprecise exceptions].++So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the+bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an+example (from #18086) where that is the case:++ioTest :: IO ()+ioTest = do+  putStrLn "hi"+  undefined++However, one can loosely say that we give a function 'botCpr' whenever its+'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just+a consequence of fixed-point iteration, it's not important that they agree.+ ************************************************************************ *                                                                      *            Demand environments and types@@ -1300,7 +1324,7 @@    - We have to multiply divergence with C_01. If r says that f Diverges for sure,      then this holds when the demand guarantees that two arguments are going to      be passed. If the demand is lower, we may just as well converge.-     If we were tracking definite convegence, than that would still hold under+     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. CM(CS(U)):    - Multiply with C_1N. Even if f puts a used-once demand on any of its argument

@@ -12,25 +12,24 @@    , isEmptyMessages    , addMessage    , unionMessages-   , ErrMsg (..)+   , MsgEnvelope (..)    , WarnMsg-   , ErrDoc (..)-   , MsgDoc+   , SDoc+   , DecoratedSDoc (unDecorated)    , Severity (..)    , RenderableDiagnostic (..)-   , errDoc-   , mapErrDoc    , pprMessageBag+   , mkDecorated    , mkLocMessage    , mkLocMessageAnn    , getSeverityColour    , getCaretDiagnostic    , makeIntoWarning    -- * Constructing individual errors-   , mkErrMsg-   , mkPlainErrMsg+   , mkMsgEnvelope+   , mkPlainMsgEnvelope    , mkErr-   , mkLongErrMsg+   , mkLongMsgEnvelope    , mkWarnMsg    , mkPlainWarnMsg    , mkLongWarnMsg@@ -68,7 +67,7 @@ be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably-shouldn't belong to an 'ErrMsg' to begin with, as it might potentially lead to the construction of+shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of "impossible states" (e.g. a waning with 'SevInfo', for example).  'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but@@ -78,7 +77,7 @@  -- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically -- a warning or an error. See Note [Messages].-newtype Messages e = Messages (Bag (ErrMsg e))+newtype Messages e = Messages (Bag (MsgEnvelope e))  instance Functor Messages where   fmap f (Messages xs) = Messages (mapBag (fmap f) xs)@@ -86,25 +85,35 @@ emptyMessages :: Messages e emptyMessages = Messages emptyBag -mkMessages :: Bag (ErrMsg e) -> Messages e+mkMessages :: Bag (MsgEnvelope e) -> Messages e mkMessages = Messages  isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs -addMessage :: ErrMsg e -> Messages e -> Messages e+addMessage :: MsgEnvelope e -> Messages e -> Messages e addMessage x (Messages xs) = Messages (x `consBag` xs)  -- | Joins two collections of messages together. unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (ErrMsg ErrDoc)-type ErrorMessages   = Bag (ErrMsg ErrDoc)+type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)+type ErrorMessages   = Bag (MsgEnvelope DecoratedSDoc) -type MsgDoc          = SDoc-type WarnMsg         = ErrMsg ErrDoc+type WarnMsg         = MsgEnvelope DecoratedSDoc +-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'+-- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets+-- between each elements of the list.+-- The type of decoration depends on the formatting function used, but in practice GHC uses the+-- 'formatBulleted'.+newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }++-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.+mkDecorated :: [SDoc] -> DecoratedSDoc+mkDecorated = Decorated+ {- Note [Rendering Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -124,7 +133,7 @@  instance RenderableDiagnostic TcRnMessage where   renderDiagnostic = \case-    TcRnOutOfScope .. -> ErrDoc [text "Out of scope error ..."] [] []+    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@@ -132,13 +141,18 @@  -} --- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'ErrDoc'.+-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'. -- For more information, see Note [Rendering Messages]. class RenderableDiagnostic a where-  renderDiagnostic :: a -> ErrDoc+  renderDiagnostic :: a -> DecoratedSDoc --- | The main 'GHC' error type, parameterised over the /domain-specific/ message.-data ErrMsg e = ErrMsg+-- | An envelope for GHC's facts about a running program, parameterised over the+-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.+--+-- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped+-- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc.+-- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.+data MsgEnvelope e = MsgEnvelope    { errMsgSpan        :: SrcSpan       -- ^ The SrcSpan is used for sorting errors into line-number order    , errMsgContext     :: PrintUnqualified@@ -147,27 +161,9 @@    , errMsgReason      :: WarnReason    } deriving Functor --- | Categorise error msgs by their importance.  This is so each section can--- be rendered visually distinct.  See Note [Error report] for where these come--- from.-data ErrDoc = ErrDoc {-        -- | Primary error msg.-        errDocImportant     :: [MsgDoc],-        -- | Context e.g. \"In the second argument of ...\".-        errDocContext       :: [MsgDoc],-        -- | Supplementary information, e.g. \"Relevant bindings include ...\".-        errDocSupplementary :: [MsgDoc]-        }--instance RenderableDiagnostic ErrDoc where+instance RenderableDiagnostic DecoratedSDoc where   renderDiagnostic = id -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc-errDoc = ErrDoc--mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc-mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)- data Severity   = SevOutput   | SevFatal@@ -194,19 +190,19 @@ instance ToJson Severity where   json s = JSString (show s) -instance Show (ErrMsg ErrDoc) where-    show = showErrMsg+instance Show (MsgEnvelope DecoratedSDoc) where+    show = showMsgEnvelope --- | Shows an 'ErrMsg'.-showErrMsg :: RenderableDiagnostic a => ErrMsg a -> String-showErrMsg err =-  renderWithContext defaultSDocContext (vcat (errDocImportant $ renderDiagnostic $ errMsgDiagnostic err))+-- | Shows an 'MsgEnvelope'.+showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String+showMsgEnvelope err =+  renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err)) -pprMessageBag :: Bag MsgDoc -> SDoc+pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))  -- | Make an unannotated error message with location info.-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc+mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc mkLocMessage = mkLocMessageAnn Nothing  -- | Make a possibly annotated error message with location info.@@ -214,8 +210,8 @@   :: Maybe String                       -- ^ optional annotation   -> Severity                           -- ^ severity   -> SrcSpan                            -- ^ location-  -> MsgDoc                             -- ^ message-  -> MsgDoc+  -> SDoc                             -- ^ message+  -> SDoc   -- 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 "<no location info>".@@ -255,7 +251,7 @@ getSeverityColour SevFatal   = Col.sFatal getSeverityColour _          = const mempty -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc+getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic severity (RealSrcSpan span _) =   caretDiagnostic <$> getSrcLine (srcSpanFile span) row@@ -331,61 +327,61 @@                       | otherwise = ""         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -makeIntoWarning :: WarnReason -> ErrMsg e -> ErrMsg e+makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e makeIntoWarning reason err = err     { errMsgSeverity = SevWarning     , errMsgReason = reason }  ----- Creating ErrMsg(s)+-- Creating MsgEnvelope(s) --  mk_err_msg-  :: Severity -> SrcSpan -> PrintUnqualified -> e -> ErrMsg e+  :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mk_err_msg sev locn print_unqual err- = ErrMsg { errMsgSpan = locn-          , errMsgContext = print_unqual-          , errMsgDiagnostic = err-          , errMsgSeverity = sev-          , errMsgReason = NoReason }+ = MsgEnvelope { errMsgSpan = locn+               , errMsgContext = print_unqual+               , errMsgDiagnostic = err+               , errMsgSeverity = sev+               , errMsgReason = NoReason } -mkErr :: SrcSpan -> PrintUnqualified -> e -> ErrMsg e+mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mkErr = mk_err_msg SevError -mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg ErrDoc+mkLongMsgEnvelope, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc -- ^ A long (multi-line) error message-mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg ErrDoc+mkMsgEnvelope, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> SDoc         -> MsgEnvelope DecoratedSDoc -- ^ A short (one-line) error message-mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg ErrDoc+mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan ->                     SDoc         -> MsgEnvelope DecoratedSDoc -- ^ Variant that doesn't care about qualified/unqualified names -mkLongErrMsg   locn unqual msg extra = mk_err_msg SevError   locn unqual        (ErrDoc [msg] [] [extra])-mkErrMsg       locn unqual msg       = mk_err_msg SevError   locn unqual        (ErrDoc [msg] [] [])-mkPlainErrMsg  locn        msg       = mk_err_msg SevError   locn alwaysQualify (ErrDoc [msg] [] [])-mkLongWarnMsg  locn unqual msg extra = mk_err_msg SevWarning locn unqual        (ErrDoc [msg] [] [extra])-mkWarnMsg      locn unqual msg       = mk_err_msg SevWarning locn unqual        (ErrDoc [msg] [] [])-mkPlainWarnMsg locn        msg       = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] [])+mkLongMsgEnvelope   locn unqual msg extra = mk_err_msg SevError   locn unqual        (mkDecorated [msg,extra])+mkMsgEnvelope       locn unqual msg       = mk_err_msg SevError   locn unqual        (mkDecorated [msg])+mkPlainMsgEnvelope  locn        msg       = mk_err_msg SevError   locn alwaysQualify (mkDecorated [msg])+mkLongWarnMsg       locn unqual msg extra = mk_err_msg SevWarning locn unqual        (mkDecorated [msg,extra])+mkWarnMsg           locn unqual msg       = mk_err_msg SevWarning locn unqual        (mkDecorated [msg])+mkPlainWarnMsg      locn        msg       = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg])  -- -- Queries -- -isErrorMessage :: ErrMsg e -> Bool+isErrorMessage :: MsgEnvelope e -> Bool isErrorMessage = (== SevError) . errMsgSeverity -isWarningMessage :: ErrMsg e -> Bool+isWarningMessage :: MsgEnvelope e -> Bool isWarningMessage = not . isErrorMessage  errorsFound :: Messages e -> Bool errorsFound (Messages msgs) = any isErrorMessage msgs -getWarningMessages :: Messages e -> Bag (ErrMsg e)+getWarningMessages :: Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs -getErrorMessages :: Messages e -> Bag (ErrMsg e)+getErrorMessages :: Messages e -> Bag (MsgEnvelope e) getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs  -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the -- second the errors.-partitionMessages :: Messages e -> (Bag (ErrMsg e), Bag (ErrMsg e))+partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) partitionMessages (Messages xs) = partitionBag isWarningMessage xs

@@ -12,26 +12,33 @@  This module defines the representation of FieldLabels as stored in TyCons.  As well as a selector name, these have some extra structure-to support the DuplicateRecordFields extension.+to support the DuplicateRecordFields and NoFieldSelectors extensions. -In the normal case (with NoDuplicateRecordFields), a datatype like+In the normal case (with NoDuplicateRecordFields and FieldSelectors),+a datatype like      data T = MkT { foo :: Int }  has -    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = False-               , flSelector     = foo }.+    FieldLabel { flLabel                    = "foo"+               , flHasDuplicateRecordFields = NoDuplicateRecordFields+               , flHasFieldSelector         = FieldSelectors+               , flSelector                 = foo }.  In particular, the Name of the selector has the same string representation as the label.  If DuplicateRecordFields is enabled, however, the same declaration instead gives -    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = True-               , flSelector     = $sel:foo:MkT }.+    FieldLabel { flLabel                    = "foo"+               , flHasDuplicateRecordFields = DuplicateRecordFields+               , flHasFieldSelector         = FieldSelectors+               , flSelector                 = $sel:foo:MkT }. +Similarly, the selector name will be mangled if NoFieldSelectors is used+(whether or not DuplicateRecordFields is enabled).  See Note [NoFieldSelectors]+in GHC.Rename.Env.+ Now the name of the selector ($sel:foo:MkT) does not match the label of the field (foo).  We must be careful not to show the selector name to the user!  The point of mangling the selector name is to allow a@@ -69,6 +76,9 @@    , FieldLabel(..)    , fieldSelectorOccName    , fieldLabelPrintableName+   , DuplicateRecordFields(..)+   , FieldSelectors(..)+   , flIsOverloaded    ) where @@ -82,6 +92,7 @@ import GHC.Utils.Outputable import GHC.Utils.Binary +import Data.Bool import Data.Data  -- | Field labels are just represented as strings;@@ -91,13 +102,17 @@ -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel - -- | Fields in an algebraic record type; see Note [FieldLabel]. data FieldLabel = FieldLabel {-      flLabel        :: FieldLabelString, -- ^ User-visible label of the field-      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on-                                          --   in the defining module for this datatype?-      flSelector     :: Name              -- ^ Record selector function+      flLabel :: FieldLabelString,+      -- ^ User-visible label of the field+      flHasDuplicateRecordFields :: DuplicateRecordFields,+      -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype?+      flHasFieldSelector :: FieldSelectors,+      -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype?+      -- See Note [NoFieldSelectors] in GHC.Rename.Env+      flSelector :: Name+      -- ^ Record selector function     }   deriving (Data, Eq) @@ -105,31 +120,65 @@   occName = mkVarOccFS . flLabel  instance Outputable FieldLabel where-    ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)))+    ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))+                                                <> ppr (flHasDuplicateRecordFields fl)+                                                <> ppr (flHasFieldSelector fl)) +-- | Flag to indicate whether the DuplicateRecordFields extension is enabled.+data DuplicateRecordFields+    = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module+    | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default)+  deriving (Show, Eq, Typeable, Data)++instance Binary DuplicateRecordFields where+    put_ bh f = put_ bh (f == DuplicateRecordFields)+    get bh = bool NoDuplicateRecordFields DuplicateRecordFields <$> get bh++instance Outputable DuplicateRecordFields where+    ppr DuplicateRecordFields   = text "+dup"+    ppr NoDuplicateRecordFields = text "-dup"+++-- | Flag to indicate whether the FieldSelectors extension is enabled.+data FieldSelectors+    = FieldSelectors   -- ^ Selector functions are available (the default)+    | NoFieldSelectors -- ^ Selector functions are not available+  deriving (Show, Eq, Typeable, Data)++instance Binary FieldSelectors where+    put_ bh f = put_ bh (f == FieldSelectors)+    get bh = bool NoFieldSelectors FieldSelectors <$> get bh++instance Outputable FieldSelectors where+    ppr FieldSelectors   = text "+sel"+    ppr NoFieldSelectors = text "-sel"++ -- | 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 -- instance is not in scope.  And the instance cannot be added to Name.hs-boot -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where-    put_ bh (FieldLabel aa ab ac) = do+    put_ bh (FieldLabel aa ab ac ad) = do         put_ bh aa         put_ bh ab         put_ bh ac+        put_ bh ad     get bh = do+        aa <- get bh         ab <- get bh         ac <- get bh         ad <- get bh-        return (FieldLabel ab ac ad)+        return (FieldLabel aa ab ac ad)   -- | Record selector OccNames are built from the underlying field name -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors].-fieldSelectorOccName :: FieldLabelString -> OccName -> Bool -> OccName-fieldSelectorOccName lbl dc is_overloaded-  | is_overloaded = mkRecFldSelOcc str+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   where     str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc@@ -142,3 +191,15 @@ fieldLabelPrintableName fl   | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl))   | otherwise         = flSelector fl++-- | Selector name mangling should be used if either DuplicateRecordFields or+-- NoFieldSelectors is enabled, so that the OccName of the field can be used for+-- something else.  See Note [FieldLabel], and Note [NoFieldSelectors] in+-- GHC.Rename.Env.+shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool+shouldMangleSelectorNames dup_fields_ok has_sel+    = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors++flIsOverloaded :: FieldLabel -> Bool+flIsOverloaded fl =+    shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl)

@@ -700,12 +700,11 @@ -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id-  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )-         not (isJoinId id) && (-           (isStrictType (idType id)) ||-           -- Take the best of both strictnesses - old and new-           (isStrUsedDmd (idDemandInfo id))-         )+  | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+    isJoinId id = False+  | otherwise   = isStrictType (idType id) ||+                  isStrUsedDmd (idDemandInfo id)+                  -- Take the best of both strictnesses - old and new          ---------------------------------         -- UNFOLDING

@@ -32,7 +32,7 @@         nullAddrId, seqId, lazyId, lazyIdKey,         coercionTokenId, magicDictId, coerceId,         proxyHashId, noinlineId, noinlineIdName,-        coerceName,+        coerceName, leftSectionName, rightSectionName,          -- Re-export error Ids         module GHC.Core.Opt.ConstantFold@@ -53,7 +53,7 @@ import GHC.Tc.Utils.TcType as TcType import GHC.Core.Make import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Utils   ( mkCast, mkDefaultCase )+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Types.Literal@@ -176,6 +176,8 @@     , magicDictId     , coerceId     , proxyHashId+    , leftSectionId+    , rightSectionId     ]  {-@@ -1427,7 +1429,8 @@  nullAddrName, seqName,    realWorldName, voidPrimIdName, coercionTokenName,-   magicDictName, coerceName, proxyName :: Name+   magicDictName, coerceName, proxyName,+   leftSectionName, rightSectionName :: Name nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId@@ -1436,6 +1439,8 @@ magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId+leftSectionName   = mkWiredInIdName gHC_PRIM  (fsLit "leftSection")    leftSectionKey     leftSectionId+rightSectionName  = mkWiredInIdName gHC_PRIM  (fsLit "rightSection")   rightSectionKey    rightSectionId  -- Names listed in magicIds; see Note [magicIds] lazyIdName, oneShotName, noinlineIdName :: Name@@ -1513,16 +1518,84 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs-    ty  = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar-                          , openAlphaTyVar, openBetaTyVar ]-                          (mkVisFunTyMany fun_ty fun_ty)+    ty  = mkInfForAllTys  [ runtimeRep1TyVar, runtimeRep2TyVar ] $+          mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ]      $+          mkVisFunTyMany fun_ty fun_ty     fun_ty = mkVisFunTyMany openAlphaTy openBetaTy     [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]     x' = setOneShotLambda x  -- Here is the magic bit!     rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar                  , openAlphaTyVar, openBetaTyVar                  , body, x'] $-          Var body `App` Var x+          Var body `App` Var x'++----------------------------------------------------------------------+{- Note [Wired-in Ids for rebindable syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions leftSectionId, rightSectionId are+wired in here ONLY because they are use in a levity-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+levity-polymorphic functions.++They have Compulsory unfoldings to so that the levity polymorphism+does not linger for long.+-}++-- See Note [Left and right sections] in GHC.Rename.Expr+-- See Note [Wired-in Ids for rebindable syntax]+--   leftSection :: forall r1 r2 n (a:Type r1) (b:TYPE r2).+--                  (a %n-> b) -> a %n-> b+--   leftSection f x = f x+-- Important that it is eta-expanded, so that (leftSection undefined `seq` ())+--   is () and not undefined+-- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList)+leftSectionId :: Id+leftSectionId = pcMiscPrelId leftSectionName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+    ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $+          mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar]    $+          exprType body+    [f,x] = mkTemplateLocals [mkVisFunTy mult openAlphaTy openBetaTy, openAlphaTy]++    mult = mkTyVarTy multiplicityTyVar1 :: Mult+    xmult = setIdMult x mult++    rhs  = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1+                  , openAlphaTyVar,   openBetaTyVar   ] body+    body = mkLams [f,xmult] $ App (Var f) (Var xmult)++-- See Note [Left and right sections] in GHC.Rename.Expr+-- See Note [Wired-in Ids for rebindable syntax]+--   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+--                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c+--   rightSection f y x = f x y+-- Again, multiplicity polymorphism is important+rightSectionId :: Id+rightSectionId = pcMiscPrelId rightSectionName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+    ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar+                          , multiplicityTyVar1, multiplicityTyVar2 ] $+          mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar,   openGammaTyVar ]  $+          exprType body+    mult1 = mkTyVarTy multiplicityTyVar1+    mult2 = mkTyVarTy multiplicityTyVar2++    [f,x,y] = mkTemplateLocals [ mkVisFunTys [ Scaled mult1 openAlphaTy+                                             , Scaled mult2 openBetaTy ] openGammaTy+                               , openAlphaTy, openBetaTy ]+    xmult = setIdMult x mult1+    ymult = setIdMult y mult2+    rhs  = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar+                  , multiplicityTyVar1, multiplicityTyVar2+                  , openAlphaTyVar,   openBetaTyVar,    openGammaTyVar ] body+    body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]  -------------------------------------------------------------------------------- magicDictId :: Id  -- See Note [magicDictId magic]

@@ -6,6 +6,7 @@  {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE AllowAmbiguousTypes #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -51,6 +52,7 @@         , isZeroLit, isOneLit         , litFitsInChar         , litValue, mapLitValue+        , isLitValue_maybe          -- ** Coercions         , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit@@ -86,6 +88,7 @@ import Data.Word import Data.Char import Data.Data ( Data )+import GHC.Exts import Numeric ( fromRat )  {-@@ -868,24 +871,13 @@ cmpLit (LitNullAddr)        (LitNullAddr)         = EQ cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b-cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `uniqCompareFS` b+cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a)    (LitNumber nt2  b)-  | nt1 == nt2 = a   `compare` b-  | otherwise  = nt1 `compare` nt2+  = (nt1 `compare` nt2) `mappend` (a `compare` b) cmpLit (LitRubbish b1)      (LitRubbish b2)       = b1 `compare` b2 cmpLit lit1 lit2-  | litTag lit1 < litTag lit2 = LT-  | otherwise                 = GT--litTag :: Literal -> Int-litTag (LitChar      _)   = 1-litTag (LitString    _)   = 2-litTag (LitNullAddr)      = 3-litTag (LitFloat     _)   = 4-litTag (LitDouble    _)   = 5-litTag (LitLabel _ _ _)   = 6-litTag (LitNumber  {})    = 7-litTag (LitRubbish {})    = 8+  | isTrue# (dataToTag# lit1 <# dataToTag# lit2) = LT+  | otherwise                                    = GT  {-         Printing

@@ -109,17 +109,27 @@  -- | A unique, unambiguous name for something, containing information about where -- that thing originated.-data Name = Name {-                n_sort :: NameSort,     -- What sort of name it is-                n_occ  :: !OccName,     -- Its occurrence name-                n_uniq :: {-# UNPACK #-} !Unique,-                n_loc  :: !SrcSpan      -- Definition site-            }+data Name = Name+  { n_sort :: NameSort+    -- ^ What sort of name it is --- NOTE: we make the n_loc field strict to eliminate some potential--- (and real!) space leaks, due to the fact that we don't look at--- the SrcLoc in a Name all that often.+  , n_occ  :: OccName+    -- ^ Its occurrence name.+    --+    -- NOTE: kept lazy to allow known names to be known constructor applications+    -- and to inline better. See Note [Fast comparison for built-in Names] +  , n_uniq :: {-# UNPACK #-} !Unique+    -- ^ Its unique.++  , n_loc  :: !SrcSpan+    -- ^ Definition site+    --+    -- NOTE: we make the n_loc field strict to eliminate some potential+    -- (and real!) space leaks, due to the fact that we don't look at+    -- the SrcLoc in a Name all that often.+  }+ -- See Note [About the NameSorts] data NameSort   = External Module@@ -157,6 +167,36 @@ data BuiltInSyntax = BuiltInSyntax | UserSyntax  {-+Note [Fast comparison for built-in Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this wired-in Name in GHC.Builtin.Names:++   int8TyConName = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey++Ultimately this turns into something like:++   int8TyConName = Name gHC_INT (mkOccName ..."Int8") int8TyConKey++So a comparison like `x == int8TyConName` will turn into `getUnique x ==+int8TyConKey`, nice and efficient.  But if the `n_occ` field is strict, that+definition will look like:++   int8TyCOnName = case (mkOccName..."Int8") of occ ->+                   Name gHC_INT occ int8TyConKey++and now the comparison will not optimise.  This matters even more when there are+numerous comparisons (see #19386):++if | tc == int8TyCon  -> ...+   | tc == int16TyCon -> ...+   ...etc...++when we would like to get a single multi-branched case.++TL;DR: we make the `n_occ` field lazy.+-}++{- Note [About the NameSorts]  1.  Initially, top-level Ids (including locally-defined ones) get External names,@@ -401,6 +441,7 @@  -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name+{-# INLINE mkExternalName #-} -- WATCH OUT! External Names should be in the Name Cache -- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName -- with some fresh unique without populating the Name Cache@@ -410,6 +451,7 @@  -- | Create a name which is actually defined by the compiler itself mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name+{-# INLINE mkWiredInName #-} mkWiredInName mod occ uniq thing built_in   = Name { n_uniq = uniq,            n_sort = WiredIn mod thing built_in,

@@ -646,7 +646,7 @@ mkInstTyCoOcc       = mk_simple_deriv tcName   "D:"   -- Coercion for type functions mkEqPredCoOcc       = mk_simple_deriv tcName   "$co" --- Used in derived instances for the names of auxilary bindings.+-- Used in derived instances for the names of auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_" mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"

@@ -46,7 +46,7 @@         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,         pprGlobalRdrEnv, globalRdrEnvElts,-        lookupGRE_RdrName, lookupGRE_Name,+        lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name,         lookupGRE_GreName, lookupGRE_FieldLabel,         lookupGRE_Name_OccName,         getGRE_NameQualifier_maybes,@@ -58,9 +58,11 @@         gresToAvailInfo,         greDefinitionModule, greDefinitionSrcSpan,         greMangledName, grePrintableName,+        greFieldLabel,          -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greFieldLabel,+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE,+        isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,         unQualOK, qualSpecOK, unQualSpecOK,         pprNameProvenance,         GreName(..), greNameSrcSpan,@@ -836,7 +838,15 @@                                   Just gres -> gres  lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]-lookupGRE_RdrName rdr_name env+-- ^ Look for this 'RdrName' in the global environment.  Omits record fields+-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).+lookupGRE_RdrName rdr_name env =+    filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env)++lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]+-- ^ Look for this 'RdrName' in the global environment.  Includes record fields+-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).+lookupGRE_RdrName' rdr_name env   = case lookupOccEnv env (rdrNameOcc rdr_name) of     Nothing   -> []     Just gres -> pickGREs rdr_name gres@@ -858,14 +868,14 @@ lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt -- ^ Look for a particular record field selector in the environment, where the -- selector name and field label may be different: the GlobalRdrEnv is keyed on--- the label.  See Note [Parents for record fields] for why this happens.+-- 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 :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' -- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and--- Note [Parents for record fields].+-- Note [GreNames]. lookupGRE_Name_OccName env name occ   = case [ gre | gre <- lookupGlobalRdrEnv env occ                , greMangledName gre == name ] of@@ -895,10 +905,23 @@ isRecFldGRE :: GlobalRdrElt -> Bool isRecFldGRE = isJust . greFieldLabel -isOverloadedRecFldGRE :: GlobalRdrElt -> Bool+isDuplicateRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields?--- (See Note [Parents for record fields])-isOverloadedRecFldGRE = maybe False flIsOverloaded . greFieldLabel+-- (See Note [GreNames])+isDuplicateRecFldGRE =+    maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel++isNoFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with NoFieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isNoFieldSelectorGRE =+    maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel++isFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with FieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isFieldSelectorGRE =+    maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel  greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel -- ^ Returns the field label of this GRE, if it has one

@@ -27,7 +27,7 @@ throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => ErrMsg ErrDoc -> io a+throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a throwOneError = throwErrors . unitBag  -- | A source error is an error that is caused by one or more errors in the

@@ -15,8 +15,14 @@    , negateIntegralLit    , negateFractionalLit    , mkIntegralLit+   , mkTHFractionalLit, rationalFromFractionalLit+   , integralFractionalLit, mkSourceFractionalLit+   , FractionalExponentBase(..)++   -- Used by the pm checker.+   , fractionalLitFromRational    , mkFractionalLit-   , integralFractionalLit+    ) where @@ -30,6 +36,7 @@  import Data.Function (on) import Data.Data+import GHC.Real ( Ratio(..) )  {- Note [Pragma source text]@@ -155,38 +162,89 @@ -- encountered in the user's source program. This allows us to pretty-print exactly what -- the user wrote, which is important e.g. for floating point numbers that can't represented -- as Doubles (we used to via Double for pretty-printing). See also #2245.+-- Note [FractionalLit representation] in GHC.HsToCore.Match.Literal+-- The actual value then is: sign * fl_signi * (fl_exp_base^fl_exp)+--                             where sign = if fl_neg then (-1) else 1+--+-- For example FL { fl_neg = True, fl_signi = 5.3, fl_exp = 4, fl_exp_base = Base10 }+-- denotes  -5300+ data FractionalLit = FL-   { fl_text :: SourceText     -- ^ How the value was written in the source-   , fl_neg :: Bool            -- ^ See Note [Negative zero] in GHC.Rename.Pat-   , fl_value :: Rational      -- ^ Numeric value of the literal-   }-   deriving (Data, Show)+    { fl_text :: SourceText     -- ^ How the value was written in the source+    , fl_neg :: Bool                        -- See Note [Negative zero]+    , fl_signi :: Rational                  -- The significand component of the literal+    , fl_exp :: Integer                     -- The exponent component of the literal+    , fl_exp_base :: FractionalExponentBase -- See Note [Fractional exponent bases]+    }+    deriving (Data, Show)   -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on -mkFractionalLit :: Real a => a -> FractionalLit-mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))-                           -- Converting to a Double here may technically lose-                           -- precision (see #15502). We could alternatively-                           -- convert to a Rational for the most accuracy, but-                           -- it would cause Floats and Doubles to be displayed-                           -- strangely, so we opt not to do this. (In contrast-                           -- to mkIntegralLit, where we always convert to an-                           -- Integer for the highest accuracy.)-                       , fl_neg = r < 0-                       , fl_value = toRational r }+-- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal+data FractionalExponentBase+  = Base2 -- Used in hex fractional literals+  | Base10+  deriving (Eq, Ord, Data, Show) +mkFractionalLit :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase+                -> FractionalLit+mkFractionalLit = FL++mkRationalWithExponentBase :: Rational -> Integer -> FractionalExponentBase -> Rational+mkRationalWithExponentBase i e feb = i * (eb ^^ e)+  where eb = case feb of Base2 -> 2 ; Base10 -> 10++fractionalLitFromRational :: Rational -> FractionalLit+fractionalLitFromRational r =  FL { fl_text = NoSourceText+                           , fl_neg = r < 0+                           , fl_signi = r+                           , fl_exp = 0+                           , fl_exp_base = Base10 }++rationalFromFractionalLit :: FractionalLit -> Rational+rationalFromFractionalLit (FL _ _ i e expBase) =+  mkRationalWithExponentBase i e expBase++mkTHFractionalLit :: Rational -> FractionalLit+mkTHFractionalLit r =  FL { fl_text = SourceText (show (realToFrac r::Double))+                             -- Converting to a Double here may technically lose+                             -- precision (see #15502). We could alternatively+                             -- convert to a Rational for the most accuracy, but+                             -- it would cause Floats and Doubles to be displayed+                             -- strangely, so we opt not to do this. (In contrast+                             -- to mkIntegralLit, where we always convert to an+                             -- Integer for the highest accuracy.)+                           , fl_neg = r < 0+                           , fl_signi = r+                           , fl_exp = 0+                           , fl_exp_base = Base10 }+ negateFractionalLit :: FractionalLit -> FractionalLit-negateFractionalLit (FL text neg value)+negateFractionalLit (FL text neg i e eb)   = case text of-      SourceText ('-':src) -> FL (SourceText src)     False value-      SourceText      src  -> FL (SourceText ('-':src)) True  value-      NoSourceText         -> FL NoSourceText (not neg) (negate value)+      SourceText ('-':src) -> FL (SourceText src)       False i e eb+      SourceText      src  -> FL (SourceText ('-':src)) True  i e eb+      NoSourceText         -> FL NoSourceText (not neg) (negate i) e eb  integralFractionalLit :: Bool -> Integer -> FractionalLit-integralFractionalLit neg i = FL { fl_text = SourceText (show i),-                                   fl_neg = neg,-                                   fl_value = fromInteger i }+integralFractionalLit neg i = FL { fl_text = SourceText (show i)+                                 , fl_neg = neg+                                 , fl_signi = i :% 1+                                 , fl_exp = 0+                                 , fl_exp_base = Base10 } +mkSourceFractionalLit :: String -> Bool -> Integer -> Integer+                      -> FractionalExponentBase+                      -> FractionalLit+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff++{- Note [fractional exponent bases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For hexadecimal rationals of+the form 0x0.3p10 the exponent is given on base 2 rather than+base 10. These are the only options, hence the sum type. See also #15646.+-}++ -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) @@ -200,14 +258,33 @@   ppr (IL (SourceText src) _ _) = text src   ppr (IL NoSourceText _ value) = text (show value) ++-- | Compare fractional lits with small exponents for value equality but+--   large values for syntactic equality.+compareFractionalLit :: FractionalLit -> FractionalLit -> Ordering+compareFractionalLit fl1 fl2+  | fl_exp fl1 < 100 && fl_exp fl2 < 100 && fl_exp fl1 >= -100 && fl_exp fl2 >= -100+    = rationalFromFractionalLit fl1 `compare` rationalFromFractionalLit fl2+  | otherwise = (compare `on` (\x -> (fl_signi x, fl_exp x, fl_exp_base x))) fl1 fl2++-- | Be wary of using this instance to compare for equal *values* when exponents are+-- large. The same value expressed in different syntactic form won't compare as equal when+-- any of the exponents is >= 100. instance Eq FractionalLit where-  (==) = (==) `on` fl_value+  (==) fl1 fl2 = case compare fl1 fl2 of+          EQ -> True+          _  -> False +-- | Be wary of using this instance to compare for equal *values* when exponents are+-- large. The same value expressed in different syntactic form won't compare as equal when+-- any of the exponents is >= 100. instance Ord FractionalLit where-  compare = compare `on` fl_value+  compare = compareFractionalLit  instance Outputable FractionalLit where-  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))+  ppr (fl@(FL {})) =+    pprWithSourceText (fl_text fl) $+      rational $ mkRationalWithExponentBase (fl_signi fl) (fl_exp fl) (fl_exp_base fl)  -- | A String Literal in the source, including its original raw format for use by -- source to source manipulation tools.

@@ -49,6 +49,7 @@         realSrcSpanStart, realSrcSpanEnd,         srcSpanFileName_maybe,         pprUserRealSpan, pprUnhelpfulSpanReason,+        pprUserSpan,         unhelpfulSpanFS,          -- ** Unsafely deconstructing SrcSpan@@ -58,7 +59,7 @@         srcSpanStartCol, srcSpanEndCol,          -- ** Predicates on SrcSpan-        isGoodSrcSpan, isOneLineSpan,+        isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,         containsSpan,          -- * StringBuffer locations@@ -79,6 +80,7 @@         -- ** Deconstructing Located         getLoc, unLoc,         unRealSrcSpan, getRealSrcSpan,+        pprLocated,          -- ** Modifying Located         mapLoc,@@ -102,6 +104,7 @@         psSpanStart,         psSpanEnd,         mkSrcSpanPs,+        combineRealSrcSpans,          -- * Layout information         LayoutInfo(..),@@ -543,6 +546,14 @@ isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s isOneLineSpan (UnhelpfulSpan _) = False +isZeroWidthSpan :: SrcSpan -> Bool+-- ^ True if the span has a width of zero, as returned for "virtual"+-- semicolons in the lexer.+-- For "bad" 'SrcSpan', it returns False+isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s+                                 && srcSpanStartCol s == srcSpanEndCol s+isZeroWidthSpan (UnhelpfulSpan _) = False+ -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool@@ -764,11 +775,21 @@    | otherwise = panic "cmpBufSpan: no BufSpan" -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where-  ppr (L l e) = -- TODO: We can't do this since Located was refactored into-                -- GenLocated:+instance (Outputable e) => Outputable (Located e) where+  ppr (L l e) = -- GenLocated:                 -- Print spans without the file name etc-                -- ifPprDebug (braces (pprUserSpan False l))+                whenPprDebug (braces (pprUserSpan False l))+             $$ ppr e+instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where+  ppr (L l e) = -- GenLocated:+                -- Print spans without the file name etc+                whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))+             $$ ppr e+++pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc+pprLocated (L l e) =+                -- Print spans without the file name etc                 whenPprDebug (braces (ppr l))              $$ ppr e 

@@ -8,10 +8,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-}--#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}-#endif  module GHC.Types.Unique.Supply (         -- * Main data type@@ -292,21 +289,11 @@ ************************************************************************ -} --- Avoids using unboxed tuples when loading into GHCi-#if !defined(GHC_LOADED_INTO_GHCI)- type UniqResult result = (# result, UniqSupply #)  pattern UniqResult :: a -> b -> (# a, b #) pattern UniqResult x y = (# x, y #) {-# COMPLETE UniqResult #-}--#else--data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply-  deriving (Functor)--#endif  -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }

@@ -68,8 +68,9 @@          -- * ArgFlags         ArgFlag(Invisible,Required,Specified,Inferred),-        isVisibleArgFlag, isInvisibleArgFlag, sameVis,         AnonArgFlag(..), Specificity(..),+        isVisibleArgFlag, isInvisibleArgFlag, isInferredArgFlag,+        sameVis,          -- * TyVar's         VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder,@@ -468,12 +469,17 @@  -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool-isVisibleArgFlag Required = True-isVisibleArgFlag _        = False+isVisibleArgFlag af = not (isInvisibleArgFlag af)  -- | Does this 'ArgFlag' classify an argument that is not written in Haskell? isInvisibleArgFlag :: ArgFlag -> Bool-isInvisibleArgFlag = not . isVisibleArgFlag+isInvisibleArgFlag (Invisible {}) = True+isInvisibleArgFlag Required       = False++isInferredArgFlag :: ArgFlag -> Bool+-- More restrictive than isInvisibleArgFlag+isInferredArgFlag (Invisible InferredSpec) = True+isInferredArgFlag _                        = False  -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function

@@ -98,8 +98,8 @@ import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST-import GHC.Utils.Error  ( debugTraceMsg, dumpIfSet_dyn,-                          withTiming, DumpFormat (..) )+import GHC.Utils.Logger+import GHC.Utils.Error import GHC.Utils.Exception  import System.Directory@@ -224,14 +224,16 @@ fromFlag = ModOrigin Nothing [] [] True  instance Semigroup ModuleOrigin where-    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =+    x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =         ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')       where g (Just b) (Just b')                 | b == b'   = Just b-                | otherwise = panic "ModOrigin: package both exposed/hidden"+                | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $+                    text "x: " <> ppr x $$ text "y: " <> ppr y             g Nothing x = x             g x Nothing = x-    _x <> _y = panic "ModOrigin: hidden module redefined"+    x <> y = pprPanic "ModOrigin: hidden module redefined" $+                 text "x: " <> ppr x $$ text "y: " <> ppr y  instance Monoid ModuleOrigin where     mempty = ModOrigin Nothing [] [] False@@ -573,18 +575,18 @@ -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'.-initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit)-initUnits dflags cached_dbs = do+initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit)+initUnits logger dflags cached_dbs = do    let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()   let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages-  let printer = debugTraceMsg dflags                    -- printer for trace messages+  let printer = debugTraceMsg logger dflags             -- printer for trace messages -  (unit_state,dbs) <- withTiming dflags (text "initializing unit database")+  (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database")                    forceUnitInfoMap                  $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) -  dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map"+  dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map"     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})                 $ pprModuleMap (moduleNameProvidersMap unit_state)) 

@@ -6,8 +6,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+#if MIN_VERSION_base(4,16,0)+#define HAS_TYPELITCHAR+#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -93,10 +97,16 @@ import System.IO.Unsafe         ( unsafeInterleaveIO ) import System.IO.Error          ( mkIOError, eofErrorType ) import GHC.Real                 ( Ratio(..) )+#if MIN_VERSION_base(4,15,0)+import GHC.ForeignPtr           ( unsafeWithForeignPtr )+#endif  type BinArray = ForeignPtr Word8 -+#if !MIN_VERSION_base(4,15,0)+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+unsafeWithForeignPtr = withForeignPtr+#endif  --------------------------------------------------------------- -- BinData@@ -111,14 +121,14 @@   put_ bh (BinData sz dat) = do     put_ bh sz     putPrim bh sz $ \dest ->-      withForeignPtr dat $ \orig ->+      unsafeWithForeignPtr dat $ \orig ->         copyBytes dest orig sz   --   get bh = do     sz <- get bh     dat <- mallocForeignPtrBytes sz     getPrim bh sz $ \orig ->-      withForeignPtr dat $ \dest ->+      unsafeWithForeignPtr dat $ \dest ->         copyBytes dest orig sz     return (BinData sz dat) @@ -226,7 +236,7 @@   h <- openBinaryFile fn WriteMode   arr <- readIORef arr_r   ix  <- readFastMutInt ix_r-  withForeignPtr arr $ \p -> hPutBuf h p ix+  unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix   hClose h  readBinMem :: FilePath -> IO BinHandle@@ -236,7 +246,7 @@   filesize' <- hFileSize h   let filesize = fromIntegral filesize'   arr <- mallocForeignPtrBytes filesize-  count <- withForeignPtr arr $ \p -> hGetBuf h p filesize+  count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize   when (count /= filesize) $        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")   hClose h@@ -280,7 +290,7 @@   when (ix + size > sz) $     expandBin h (ix + size)   arr <- readIORef arr_r-  withForeignPtr arr $ \op -> f (op `plusPtr` ix)+  unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)   writeFastMutInt ix_r (ix + size)  -- -- | Similar to putPrim but advances the index by the actual number of@@ -302,7 +312,9 @@   when (ix + size > sz) $       ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)   arr <- readIORef arr_r-  w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)+  w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)+    -- This is safe WRT #17760 as we we guarantee that the above line doesn't+    -- diverge   writeFastMutInt ix_r (ix + size)   return w 

@@ -5,6 +5,9 @@  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-orphans #-}+#if MIN_VERSION_base(4,16,0)+#define HAS_TYPELITCHAR+#endif  -- | Orphan Binary instances for Data.Typeable stuff module GHC.Utils.Binary.Typeable@@ -177,11 +180,17 @@ instance Binary TypeLitSort where     put_ bh TypeLitSymbol = putByte bh 0     put_ bh TypeLitNat = putByte bh 1+#if defined(HAS_TYPELITCHAR)+    put_ bh TypeLitChar = putByte bh 2+#endif     get bh = do         tag <- getByte bh         case tag of           0 -> pure TypeLitSymbol           1 -> pure TypeLitNat+#if defined(HAS_TYPELITCHAR)+          2 -> pure TypeLitChar+#endif           _ -> fail "Binary.putTypeLitSort: invalid tag"  putTypeRep :: BinHandle -> TypeRep a -> IO ()@@ -212,4 +221,3 @@         the_type <- get bh         bytes <- get bh         return (Serialized the_type bytes)-

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns    #-} {-# LANGUAGE CPP             #-} {-# LANGUAGE RankNTypes      #-}+{-# LANGUAGE ViewPatterns    #-}  {- (c) The AQUA Project, Glasgow University, 1994-1998@@ -14,22 +15,22 @@         Severity(..),          -- * Messages-        ErrMsg(..),-        ErrDoc(..), errDoc,-        mapErrDoc,-        WarnMsg, MsgDoc,+        WarnMsg,+        MsgEnvelope(..),+        SDoc,+        DecoratedSDoc(unDecorated),         Messages, ErrorMessages, WarningMessages,         unionMessages,         errorsFound, isEmptyMessages,          -- ** Formatting-        pprMessageBag, pprErrMsgBagWithLoc,-        pprLocErrMsg,-        formatErrDoc,+        pprMessageBag, pprMsgEnvelopeBagWithLoc,+        pprLocMsgEnvelope,+        formatBulleted,          -- ** Construction-        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,-        mkErrMsg, mkPlainErrMsg, mkErr, mkLongErrMsg, mkWarnMsg,+        emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,+        mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,         mkPlainWarnMsg,         mkLongWarnMsg, @@ -37,13 +38,6 @@         doIfSet, doIfSet_dyn,         getCaretDiagnostic, -        -- * Dump files-        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,-        dumpOptionsFromFlag, DumpOptions (..),-        DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,-        TraceAction, traceAction, defaultTraceAction,-        touchDumpFile,-         -- * Issuing messages during compilation         putMsg, printInfoForUser, printOutputForUser,         logInfo, logOutput,@@ -51,7 +45,7 @@         fatalErrorMsg, fatalErrorMsg'',         compilationProgressMsg,         showPass,-        withTiming, withTimingSilent, withTimingD, withTimingSilentD,+        withTiming, withTimingSilent,         debugTraceMsg,         ghcExit,         prettyPrintGhcErrors,@@ -71,31 +65,25 @@ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc -import System.Directory import System.Exit      ( ExitCode(..), exitWith )-import System.FilePath  ( takeDirectory, (</>) )-import Data.List        ( sortBy, stripPrefix )-import qualified Data.Set as Set-import Data.IORef+import Data.List        ( sortBy ) import Data.Maybe       ( fromMaybe ) import Data.Function-import Data.Time import Debug.Trace import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle)-import System.IO import GHC.Conc         ( getAllocationCounter ) import System.CPUTime - ------------------------- data Validity   = IsValid            -- ^ Everything is fine-  | NotValid MsgDoc    -- ^ A problem, and some indication of why+  | NotValid SDoc    -- ^ A problem, and some indication of why  isValid :: Validity -> Bool isValid IsValid       = True@@ -110,7 +98,7 @@ allValid []       = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [MsgDoc]+getInvalids :: [Validity] -> [SDoc] getInvalids vs = [d | NotValid d <- vs]  orValid :: Validity -> Validity -> Validity@@ -121,28 +109,29 @@ -- Collecting up messages for later ordering and printing.  -----------------formatErrDoc :: SDocContext -> ErrDoc -> SDoc-formatErrDoc ctx (ErrDoc important context supplementary)+-- | Formats the input list of structured document, where each element of the list gets a bullet.+formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc+formatBulleted ctx (unDecorated -> docs)   = case msgs of-        [msg] -> vcat msg-        _ -> vcat $ map starred msgs+        []    -> Outputable.empty+        [msg] -> msg+        _     -> vcat $ map starred msgs     where-    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx))-        [important, context, supplementary]-    starred = (bullet<+>) . vcat+    msgs    = filter (not . Outputable.isEmpty ctx) docs+    starred = (bullet<+>) -pprErrMsgBagWithLoc :: Bag (ErrMsg ErrDoc) -> [SDoc]-pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]+pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]+pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] -pprLocErrMsg :: RenderableDiagnostic e => ErrMsg e -> SDoc-pprLocErrMsg (ErrMsg { errMsgSpan      = s-                     , errMsgDiagnostic = e-                     , errMsgSeverity  = sev-                     , errMsgContext   = unqual })+pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc+pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s+                               , errMsgDiagnostic = e+                               , errMsgSeverity  = sev+                               , errMsgContext   = unqual })   = sdocWithContext $ \ctx ->-    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx $ renderDiagnostic e)+    withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e) -sortMsgBag :: Maybe DynFlags -> Bag (ErrMsg e) -> [ErrMsg e]+sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList   where cmp           | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest@@ -151,10 +140,10 @@           Nothing        -> id           Just err_limit -> take err_limit -ghcExit :: DynFlags -> Int -> IO ()-ghcExit dflags val+ghcExit :: Logger -> DynFlags -> Int -> IO ()+ghcExit logger dflags val   | val == 0  = exitWith ExitSuccess-  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")+  | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n")                    exitWith (ExitFailure val)  doIfSet :: Bool -> IO () -> IO ()@@ -166,180 +155,6 @@                                | otherwise        = return ()  -- -------------------------------------------------------------------------------- Dumping--dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()-dumpIfSet dflags flag hdr doc-  | not flag   = return ()-  | otherwise  = doDump dflags hdr doc-{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]---- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated--- despite the fact that 'dumpIfSet' has an @INLINE@.-doDump :: DynFlags -> String -> SDoc -> IO ()-doDump dflags hdr doc =-  putLogMsg dflags-            NoReason-            SevDump-            noSrcSpan-            (withPprStyle defaultDumpStyle-              (mkDumpDoc hdr doc))---- | A wrapper around 'dumpAction'.--- First check whether the dump flag is set--- Do nothing if it is unset-dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify-{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]---- | A wrapper around 'dumpAction'.--- First check whether the dump flag is set--- Do nothing if it is unset------ Unlike 'dumpIfSet_dyn', has a printer argument-dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String-                         -> DumpFormat -> SDoc -> IO ()-dumpIfSet_dyn_printer printer dflags flag hdr fmt doc-  = when (dopt flag dflags) $ do-      let sty = mkDumpStyle printer-      dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc-{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]--mkDumpDoc :: String -> SDoc -> SDoc-mkDumpDoc hdr doc-   = vcat [blankLine,-           line <+> text hdr <+> line,-           doc,-           blankLine]-     where-        line = text (replicate 20 '=')----- | Ensure that a dump file is created even if it stays empty-touchDumpFile :: DynFlags -> DumpOptions -> IO ()-touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ()))---- | Run an action with the handle of a 'DumpFlag' if we are outputting to a--- file, otherwise 'Nothing'.-withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()-withDumpFileHandle dflags dumpOpt action = do-    let mFile = chooseDumpFile dflags dumpOpt-    case mFile of-      Just fileName -> do-        let gdref = generatedDumps dflags-        gd <- readIORef gdref-        let append = Set.member fileName gd-            mode = if append then AppendMode else WriteMode-        unless append $-            writeIORef gdref (Set.insert fileName gd)-        createDirectoryIfMissing True (takeDirectory fileName)-        withFile fileName mode $ \handle -> do-            -- We do not want the dump file to be affected by-            -- environment variables, but instead to always use-            -- UTF8. See:-            -- https://gitlab.haskell.org/ghc/ghc/issues/10762-            hSetEncoding handle utf8--            action (Just handle)-      Nothing -> action Nothing----- | Write out a dump.--- If --dump-to-file is set then this goes to a file.--- otherwise emit to stdout.------ When @hdr@ is empty, we print in a more compact format (no separators and--- blank lines)-dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()-dumpSDocWithStyle sty dflags dumpOpt hdr doc =-    withDumpFileHandle dflags dumpOpt writeDump-  where-    -- write dump to file-    writeDump (Just handle) = do-        doc' <- if null hdr-                then return doc-                else do t <- getCurrentTime-                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)-                                          then empty-                                          else text (show t)-                        let d = timeStamp-                                $$ blankLine-                                $$ doc-                        return $ mkDumpDoc hdr d-        -- When we dump to files we use UTF8. Which allows ascii spaces.-        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')--    -- write the dump to stdout-    writeDump Nothing = do-        let (doc', severity)-              | null hdr  = (doc, SevOutput)-              | otherwise = (mkDumpDoc hdr doc, SevDump)-        putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc')----- | Choose where to put a dump file based on DynFlags----chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath-chooseDumpFile dflags dumpOpt--        | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt-        , Just prefix <- getPrefix-        = Just $ setDir (prefix ++ dumpSuffix dumpOpt)--        | otherwise-        = Nothing--        where getPrefix-                 -- dump file location is being forced-                 --      by the --ddump-file-prefix flag.-               | Just prefix <- dumpPrefixForce dflags-                  = Just prefix-                 -- dump file location chosen by GHC.Driver.Pipeline.runPipeline-               | Just prefix <- dumpPrefix dflags-                  = Just prefix-                 -- we haven't got a place to put a dump file.-               | otherwise-                  = Nothing-              setDir f = case dumpDir dflags of-                         Just d  -> d </> f-                         Nothing ->       f---- | Dump options------ Dumps are printed on stdout by default except when the `dumpForcedToFile`--- field is set to True.------ When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are--- written into a file whose suffix is given in the `dumpSuffix` field.----data DumpOptions = DumpOptions-   { dumpForcedToFile :: Bool   -- ^ Must be dumped into a file, even if-                                --   -ddump-to-file isn't set-   , dumpSuffix       :: String -- ^ Filename suffix used when dumped into-                                --   a file-   }---- | Create dump options from a 'DumpFlag'-dumpOptionsFromFlag :: DumpFlag -> DumpOptions-dumpOptionsFromFlag Opt_D_th_dec_file =-   DumpOptions                        -- -dth-dec-file dumps expansions of TH-      { dumpForcedToFile = True       -- splices into MODULE.th.hs even when-      , dumpSuffix       = "th.hs"    -- -ddump-to-file isn't set-      }-dumpOptionsFromFlag flag =-   DumpOptions-      { dumpForcedToFile = False-      , dumpSuffix       = suffix -- build a suffix from the flag name-      }                           -- e.g. -ddump-asm => ".dump-asm"-   where-      str  = show flag-      suff = case stripPrefix "Opt_D_" str of-             Just x  -> x-             Nothing -> panic ("Bad flag name: " ++ str)-      suffix = map (\c -> if c == '_' then '-' else c) suff----- ----------------------------------------------------------------------------- -- Outputting messages from the compiler  -- We want all messages to go through one place, so that we can@@ -353,32 +168,32 @@   | otherwise               = return () {-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities] -errorMsg :: DynFlags -> MsgDoc -> IO ()-errorMsg dflags msg-   = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg+errorMsg :: Logger -> DynFlags -> SDoc -> IO ()+errorMsg logger dflags msg+   = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg -warningMsg :: DynFlags -> MsgDoc -> IO ()-warningMsg dflags msg-   = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg+warningMsg :: Logger -> DynFlags -> SDoc -> IO ()+warningMsg logger dflags msg+   = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()-fatalErrorMsg dflags msg =-    putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg+fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()+fatalErrorMsg logger dflags msg =+    putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg  fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg -compilationProgressMsg :: DynFlags -> SDoc -> IO ()-compilationProgressMsg dflags msg = do+compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()+compilationProgressMsg logger dflags msg = do     let str = showSDoc dflags msg     traceEventIO $ "GHC progress: " ++ str     ifVerbose dflags 1 $-        logOutput dflags $ withPprStyle defaultUserStyle msg+        logOutput logger dflags $ withPprStyle defaultUserStyle msg -showPass :: DynFlags -> String -> IO ()-showPass dflags what+showPass :: Logger -> DynFlags -> String -> IO ()+showPass logger dflags what   = ifVerbose dflags 2 $-    logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)+    logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)  data PrintTimings = PrintTimings | DontPrintTimings   deriving (Eq, Show)@@ -408,26 +223,15 @@ -- -- See Note [withTiming] for more. withTiming :: MonadIO m-           => DynFlags     -- ^ DynFlags+           => Logger+           -> DynFlags     -- ^ DynFlags            -> SDoc         -- ^ The name of the phase            -> (a -> ())    -- ^ A function to force the result                            -- (often either @const ()@ or 'rnf')            -> m a          -- ^ The body of the phase to be timed            -> m a-withTiming dflags what force action =-  withTiming' dflags what force PrintTimings action---- | Like withTiming but get DynFlags from the Monad.-withTimingD :: (MonadIO m, HasDynFlags m)-           => SDoc         -- ^ The name of the phase-           -> (a -> ())    -- ^ A function to force the result-                           -- (often either @const ()@ or 'rnf')-           -> m a          -- ^ The body of the phase to be timed-           -> m a-withTimingD what force action = do-  dflags <- getDynFlags-  withTiming' dflags what force PrintTimings action-+withTiming logger dflags what force action =+  withTiming' logger dflags what force PrintTimings action  -- | Same as 'withTiming', but doesn't print timings in the --   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).@@ -435,45 +239,30 @@ --   See Note [withTiming] for more. withTimingSilent   :: MonadIO m-  => DynFlags   -- ^ DynFlags+  => Logger+  -> DynFlags   -- ^ DynFlags   -> SDoc       -- ^ The name of the phase   -> (a -> ())  -- ^ A function to force the result                 -- (often either @const ()@ or 'rnf')   -> m a        -- ^ The body of the phase to be timed   -> m a-withTimingSilent dflags what force action =-  withTiming' dflags what force DontPrintTimings action---- | Same as 'withTiming', but doesn't print timings in the---   console (when given @-vN@, @N >= 2@ or @-ddump-timings@)---   and gets the DynFlags from the given Monad.------   See Note [withTiming] for more.-withTimingSilentD-  :: (MonadIO m, HasDynFlags m)-  => SDoc       -- ^ The name of the phase-  -> (a -> ())  -- ^ A function to force the result-                -- (often either @const ()@ or 'rnf')-  -> m a        -- ^ The body of the phase to be timed-  -> m a-withTimingSilentD what force action = do-  dflags <- getDynFlags-  withTiming' dflags what force DontPrintTimings action+withTimingSilent logger dflags what force action =+  withTiming' logger dflags what force DontPrintTimings action  -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m-            => DynFlags   -- ^ A means of getting a 'DynFlags' (often-                            -- 'getDynFlags' will work here)+            => Logger+            -> DynFlags   -- ^ 'DynFlags'             -> SDoc         -- ^ The name of the phase             -> (a -> ())    -- ^ A function to force the result                             -- (often either @const ()@ or 'rnf')             -> PrintTimings -- ^ Whether to print the timings             -> m a          -- ^ The body of the phase to be timed             -> m a-withTiming' dflags what force_result prtimings action+withTiming' logger dflags what force_result prtimings action   = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags     then do whenPrintTimings $-              logInfo dflags $ withPprStyle defaultUserStyle $+              logInfo logger dflags $ withPprStyle defaultUserStyle $                 text "***" <+> what <> colon             let ctx = initDefaultSDocContext dflags             alloc0 <- liftIO getAllocationCounter@@ -491,7 +280,7 @@                 time = realToFrac (end - start) * 1e-9              when (verbosity dflags >= 2 && prtimings == PrintTimings)-                $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle+                $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle                     (text "!!!" <+> what <> colon <+> text "finished in"                      <+> doublePrec 2 time                      <+> text "milliseconds"@@ -501,7 +290,7 @@                      <+> text "megabytes")              whenPrintTimings $-                dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText+                dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText                     $ text $ showSDocOneLine ctx                     $ hsep [ what <> colon                            , text "alloc=" <> ppr alloc@@ -528,31 +317,31 @@           eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w           eventEndsDoc   ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()-debugTraceMsg dflags val msg =+debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()+debugTraceMsg logger dflags val msg =    ifVerbose dflags val $-      logInfo dflags (withPprStyle defaultDumpStyle msg)+      logInfo logger dflags (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities] -putMsg :: DynFlags -> MsgDoc -> IO ()-putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg)+putMsg :: Logger -> DynFlags -> SDoc -> IO ()+putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg) -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()-printInfoForUser dflags print_unqual msg-  = logInfo dflags (withUserStyle print_unqual AllTheWay msg)+printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()+printInfoForUser logger dflags print_unqual msg+  = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()-printOutputForUser dflags print_unqual msg-  = logOutput dflags (withUserStyle print_unqual AllTheWay msg)+printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()+printOutputForUser logger dflags print_unqual msg+  = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg) -logInfo :: DynFlags -> MsgDoc -> IO ()-logInfo dflags msg-  = putLogMsg dflags NoReason SevInfo noSrcSpan msg+logInfo :: Logger -> DynFlags -> SDoc -> IO ()+logInfo logger dflags msg+  = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg  -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'-logOutput :: DynFlags -> MsgDoc -> IO ()-logOutput dflags msg-  = putLogMsg dflags NoReason SevOutput noSrcSpan msg+logOutput :: Logger -> DynFlags -> SDoc -> IO ()+logOutput logger dflags msg+  = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg  prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags@@ -568,12 +357,12 @@       where          ctx = initSDocContext dflags defaultUserStyle -traceCmd :: DynFlags -> String -> String -> IO a -> IO a+traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity)-traceCmd dflags phase_name cmd_line action+traceCmd logger dflags phase_name cmd_line action  = do   { let verb = verbosity dflags-        ; showPass dflags phase_name-        ; debugTraceMsg dflags 3 (text cmd_line)+        ; showPass logger dflags phase_name+        ; debugTraceMsg logger dflags 3 (text cmd_line)         ; case flushErr dflags of               FlushErr io -> io @@ -581,8 +370,8 @@         ; action `catchIO` handle_exn verb         }   where-    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')-                              ; debugTraceMsg dflags 2+    handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n')+                              ; debugTraceMsg logger dflags 2                                 (text "Failed:"                                  <+> text cmd_line                                  <+> text (show exn))@@ -685,41 +474,3 @@ -}  --- | Format of a dump------ Dump formats are loosely defined: dumps may contain various additional--- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint--- (e.g. for syntax highlighters).-data DumpFormat-   = FormatHaskell   -- ^ Haskell-   | FormatCore      -- ^ Core-   | FormatSTG       -- ^ STG-   | FormatByteCode  -- ^ ByteCode-   | FormatCMM       -- ^ Cmm-   | FormatASM       -- ^ Assembly code-   | FormatC         -- ^ C code/header-   | FormatLLVM      -- ^ LLVM bytecode-   | FormatText      -- ^ Unstructured dump-   deriving (Show,Eq)--type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String-                  -> DumpFormat -> SDoc -> IO ()--type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a---- | Default action for 'dumpAction' hook-defaultDumpAction :: DumpAction-defaultDumpAction dflags sty dumpOpt title _fmt doc =-  dumpSDocWithStyle sty dflags dumpOpt title doc---- | Default action for 'traceAction' hook-defaultTraceAction :: TraceAction-defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc---- | Helper for `dump_action`-dumpAction :: DumpAction-dumpAction dflags = dump_action dflags dflags---- | Helper for `trace_action`-traceAction :: TraceAction-traceAction dflags = trace_action dflags dflags

@@ -1,31 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module GHC.Utils.Error where--import GHC.Prelude-import GHC.Utils.Outputable (SDoc, PprStyle )-import {-# SOURCE #-} GHC.Driver.Session ( DynFlags )--type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String-                  -> DumpFormat -> SDoc -> IO ()--type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a--data DumpOptions = DumpOptions-   { dumpForcedToFile :: Bool-   , dumpSuffix       :: String-   }--data DumpFormat-  = FormatHaskell-  | FormatCore-  | FormatSTG-  | FormatByteCode-  | FormatCMM-  | FormatASM-  | FormatC-  | FormatLLVM-  | FormatText--defaultDumpAction :: DumpAction-defaultTraceAction :: TraceAction

@@ -0,0 +1,473 @@+{-# LANGUAGE RankNTypes #-}++-- | Logger+module GHC.Utils.Logger+    ( Logger+    , initLogger+    , HasLogger (..)+    , ContainsLogger (..)+    , LogAction+    , DumpAction+    , TraceAction+    , DumpFormat (..)+    , putLogMsg+    , putDumpMsg+    , putTraceMsg++    -- * Hooks+    , popLogHook+    , pushLogHook+    , popDumpHook+    , pushDumpHook+    , popTraceHook+    , pushTraceHook+    , makeThreadSafe++    -- * Logging+    , jsonLogAction+    , defaultLogAction+    , defaultLogActionHPrintDoc+    , defaultLogActionHPutStrDoc++    -- * Dumping+    , defaultDumpAction+    , withDumpFileHandle+    , touchDumpFile+    , dumpIfSet+    , dumpIfSet_dyn+    , dumpIfSet_dyn_printer++    -- * Tracing+    , defaultTraceAction+    )+where++import GHC.Prelude+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Types.Error+import GHC.Types.SrcLoc++import qualified GHC.Utils.Ppr as Pretty+import GHC.Utils.Outputable+import GHC.Utils.Json+import GHC.Utils.Panic++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 Data.Time+import System.IO+import Control.Monad+import Control.Concurrent.MVar+import System.IO.Unsafe++type LogAction = DynFlags+              -> WarnReason+              -> Severity+              -> SrcSpan+              -> SDoc+              -> IO ()++type DumpAction = DynFlags+               -> PprStyle+               -> DumpFlag+               -> String+               -> DumpFormat+               -> SDoc+               -> IO ()++type TraceAction a = DynFlags -> String -> SDoc -> a -> a++-- | Format of a dump+--+-- Dump formats are loosely defined: dumps may contain various additional+-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint+-- (e.g. for syntax highlighters).+data DumpFormat+   = FormatHaskell   -- ^ Haskell+   | FormatCore      -- ^ Core+   | FormatSTG       -- ^ STG+   | FormatByteCode  -- ^ ByteCode+   | FormatCMM       -- ^ Cmm+   | FormatASM       -- ^ Assembly code+   | FormatC         -- ^ C code/header+   | FormatLLVM      -- ^ LLVM bytecode+   | FormatText      -- ^ Unstructured dump+   deriving (Show,Eq)++type DumpCache = IORef (Set FilePath)++data Logger = Logger+    { log_hook   :: [LogAction -> LogAction]+        -- ^ Log hooks stack++    , dump_hook  :: [DumpAction -> DumpAction]+        -- ^ Dump hooks stack++    , trace_hook :: forall a. [TraceAction a -> TraceAction a]+        -- ^ Trace hooks stack++    , generated_dumps :: DumpCache+        -- ^ Already dumped files (to append instead of overwriting them)+    }++initLogger :: IO Logger+initLogger = do+    dumps <- newIORef Set.empty+    return $ Logger+        { log_hook        = []+        , dump_hook       = []+        , trace_hook      = []+        , generated_dumps = dumps+        }++-- | Log something+putLogMsg :: Logger -> LogAction+putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)++-- | Dump something+putDumpMsg :: Logger -> DumpAction+putDumpMsg logger =+    let+        fallback = putLogMsg logger+        dumps    = generated_dumps logger+        deflt    = defaultDumpAction dumps fallback+    in foldr ($) deflt (dump_hook logger)++-- | Trace something+putTraceMsg :: Logger -> TraceAction a+putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)+++-- | Push a log hook+pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger+pushLogHook h logger = logger { log_hook = h:log_hook logger }++-- | Pop a log hook+popLogHook :: Logger -> Logger+popLogHook logger = case log_hook logger of+    []   -> panic "popLogHook: empty hook stack"+    _:hs -> logger { log_hook = hs }++-- | Push a dump hook+pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger+pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }++-- | Pop a dump hook+popDumpHook :: Logger -> Logger+popDumpHook logger = case dump_hook logger of+    []   -> panic "popDumpHook: empty hook stack"+    _:hs -> logger { dump_hook = hs }++-- | Push a trace hook+pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger+pushTraceHook h logger = logger { trace_hook = h:trace_hook logger }++-- | Pop a trace hook+popTraceHook :: Logger -> Logger+popTraceHook logger = case trace_hook logger of+    [] -> panic "popTraceHook: empty hook stack"+    _  -> logger { trace_hook = tail (trace_hook logger) }++-- | Make the logger thread-safe+makeThreadSafe :: Logger -> IO Logger+makeThreadSafe logger = do+    lock <- newMVar ()+    let+        with_lock :: forall a. IO a -> IO a+        with_lock act = withMVar lock (const act)++        log action dflags reason sev loc doc =+            with_lock (action dflags reason sev loc doc)++        dmp action dflags sty opts str fmt doc =+            with_lock (action dflags sty opts str fmt doc)++        trc :: forall a. TraceAction a -> TraceAction a+        trc action dflags str doc v =+            unsafePerformIO (with_lock (return $! action dflags str doc v))++    return $ pushLogHook log+           $ pushDumpHook dmp+           $ pushTraceHook trc+           $ logger++-- See Note [JSON Error Messages]+--+jsonLogAction :: LogAction+jsonLogAction dflags reason severity srcSpan msg+  =+    defaultLogActionHPutStrDoc dflags True stdout+      (withPprStyle (PprCode CStyle) (doc $$ text ""))+    where+      str = renderWithContext (initSDocContext dflags defaultUserStyle) msg+      doc = renderJSON $+              JSObject [ ( "span", json srcSpan )+                       , ( "doc" , JSString str )+                       , ( "severity", json severity )+                       , ( "reason" ,   json reason )+                       ]+++defaultLogAction :: LogAction+defaultLogAction dflags reason severity srcSpan msg+  | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg+  | otherwise = case severity of+      SevOutput      -> printOut msg+      SevDump        -> printOut (msg $$ blankLine)+      SevInteractive -> putStrSDoc msg+      SevInfo        -> printErrs msg+      SevFatal       -> printErrs msg+      SevWarning     -> printWarns+      SevError       -> printWarns+    where+      printOut   = defaultLogActionHPrintDoc  dflags False stdout+      printErrs  = defaultLogActionHPrintDoc  dflags False stderr+      putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout+      -- Pretty print the warning flag, if any (#10752)+      message = mkLocMessageAnn flagMsg severity srcSpan msg++      printWarns = do+        hPutChar stderr '\n'+        caretDiagnostic <-+            if gopt Opt_DiagnosticsShowCaret dflags+            then getCaretDiagnostic severity srcSpan+            else pure empty+        printErrs $ getPprStyle $ \style ->+          withPprStyle (setStyleColoured True style)+            (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 =+        case reason of+          NoReason -> Nothing+          Reason wflag -> do+            spec <- flagSpecOf wflag+            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)+          ErrReason Nothing ->+            return "-Werror"+          ErrReason (Just wflag) -> do+            spec <- flagSpecOf wflag+            return $+              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag +++              ", -Werror=" ++ flagSpecName spec++      warnFlagGrp flag+          | gopt Opt_ShowWarnGroups dflags =+                case smallestGroups flag of+                    [] -> ""+                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"+          | otherwise = ""++-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.+defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPrintDoc dflags asciiSpace h d+ = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")++-- | The boolean arguments let's the pretty printer know if it can optimize indent+-- by writing ascii ' ' characters without going through decoding.+defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPutStrDoc dflags asciiSpace h d+  -- Don't add a newline at the end, so that successive+  -- calls to this log-action can output all on the same line+  = printSDoc ctx (Pretty.PageMode asciiSpace) h d+    where+      ctx = initSDocContext dflags defaultUserStyle++--+-- Note [JSON Error Messages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When the user requests the compiler output to be dumped as json+-- we used to collect them all in an IORef and then print them at the end.+-- This doesn't work very well with GHCi. (See #14078) So instead we now+-- use the simpler method of just outputting a JSON document inplace to+-- stdout.+--+-- Before the compiler calls log_action, it has already turned the `ErrMsg`+-- into a formatted message. This means that we lose some possible+-- information to provide to the user but refactoring log_action is quite+-- invasive as it is called in many places. So, for now I left it alone+-- and we can refine its behaviour as users request different output.++-- | Default action for 'dumpAction' hook+defaultDumpAction :: DumpCache -> LogAction -> DumpAction+defaultDumpAction dumps log_action dflags sty flag title _fmt doc =+  dumpSDocWithStyle dumps log_action sty dflags flag title doc++-- | 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).+--+-- When @hdr@ is empty, we print in a more compact format (no separators and+-- blank lines)+dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpSDocWithStyle dumps log_action sty dflags flag hdr doc =+    withDumpFileHandle dumps dflags flag writeDump+  where+    -- write dump to file+    writeDump (Just handle) = do+        doc' <- if null hdr+                then return doc+                else do t <- getCurrentTime+                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)+                                          then empty+                                          else text (show t)+                        let d = timeStamp+                                $$ blankLine+                                $$ doc+                        return $ mkDumpDoc hdr d+        -- When we dump to files we use UTF8. Which allows ascii spaces.+        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')++    -- write the dump to stdout+    writeDump Nothing = do+        let (doc', severity)+              | null hdr  = (doc, SevOutput)+              | otherwise = (mkDumpDoc hdr doc, SevDump)+        log_action dflags NoReason severity noSrcSpan (withPprStyle sty doc')+++-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a+-- file, otherwise 'Nothing'.+withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()+withDumpFileHandle dumps dflags flag action = do+    let mFile = chooseDumpFile dflags 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+            -- We do not want the dump file to be affected by+            -- environment variables, but instead to always use+            -- UTF8. See:+            -- https://gitlab.haskell.org/ghc/ghc/issues/10762+            hSetEncoding handle utf8++            action (Just handle)+      Nothing -> action Nothing++-- | Choose where to put a dump file based on DynFlags and DumpFlag+chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath+chooseDumpFile dflags flag+    | gopt Opt_DumpToFile dflags || forced_to_file+    , Just prefix <- getPrefix+    = Just $ setDir (prefix ++ dump_suffix)++    | otherwise+    = Nothing+  where+    (forced_to_file, dump_suffix) = case flag of+        -- -dth-dec-file dumps expansions of TH+        -- splices into MODULE.th.hs even when+        -- -ddump-to-file isn't set+        Opt_D_th_dec_file -> (True, "th.hs")+        _                 -> (False, default_suffix)++    -- build a suffix from the flag name+    -- e.g. -ddump-asm => ".dump-asm"+    default_suffix = map (\c -> if c == '_' then '-' else c) $+      let str = show flag+      in case stripPrefix "Opt_D_" str of+        Just x  -> x+        Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str)++    getPrefix+         -- dump file location is being forced+         --      by the --ddump-file-prefix flag.+       | Just prefix <- dumpPrefixForce dflags+          = Just prefix+         -- dump file location chosen by GHC.Driver.Pipeline.runPipeline+       | Just prefix <- dumpPrefix dflags+          = Just prefix+         -- we haven't got a place to put a dump file.+       | otherwise+          = Nothing+    setDir f = case dumpDir dflags of+                 Just d  -> d </> f+                 Nothing ->       f++-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated+-- despite the fact that 'dumpIfSet' has an @INLINE@.+doDump :: Logger -> DynFlags -> String -> SDoc -> IO ()+doDump logger dflags hdr doc =+  putLogMsg logger dflags+            NoReason+            SevDump+            noSrcSpan+            (withPprStyle defaultDumpStyle+              (mkDumpDoc hdr doc))++mkDumpDoc :: String -> SDoc -> SDoc+mkDumpDoc hdr doc+   = vcat [blankLine,+           line <+> text hdr <+> line,+           doc,+           blankLine]+     where+        line = text "===================="+++dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()+dumpIfSet logger dflags flag hdr doc+  | not flag   = return ()+  | otherwise  = doDump logger dflags hdr doc+{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]++-- | A wrapper around 'dumpAction'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify+{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]++-- | A wrapper around 'putDumpMsg'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+--+-- Unlike 'dumpIfSet_dyn', has a printer argument+dumpIfSet_dyn_printer+    :: PrintUnqualified+    -> Logger+    -> DynFlags+    -> DumpFlag+    -> String+    -> DumpFormat+    -> SDoc+    -> IO ()+dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc+  = when (dopt flag dflags) $ do+      let sty = mkDumpStyle printer+      putDumpMsg logger dflags sty flag hdr fmt doc+{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]++-- | Ensure that a dump file is created even if it stays empty+touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO ()+touchDumpFile logger dflags flag =+    withDumpFileHandle (generated_dumps logger) dflags flag (const (return ()))+++-- | Default action for 'traceAction' hook+defaultTraceAction :: TraceAction a+defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc++++class HasLogger m where+    getLogger :: m Logger++class ContainsLogger t where+    extractLogger :: t -> Logger+