ghc-lib-parser 0.20211001 → 0.20211101
raw patch · 114 files changed
+3950/−2273 lines, 114 filesdep ~bytestringdep ~ghc-primdep ~time
Dependency ranges changed: bytestring, ghc-prim, time
Files
- compiler/GHC/Builtin/Names.hs +47/−98
- compiler/GHC/Builtin/PrimOps.hs +2/−2
- compiler/GHC/Builtin/Types/Prim.hs +36/−1
- compiler/GHC/Builtin/Uniques.hs +3/−19
- compiler/GHC/Builtin/Uniques.hs-boot +3/−5
- compiler/GHC/Cmm/MachOp.hs +4/−2
- compiler/GHC/CmmToAsm/Config.hs +1/−0
- compiler/GHC/Core.hs +24/−18
- compiler/GHC/Core/ConLike.hs +7/−0
- compiler/GHC/Core/Lint.hs +29/−29
- compiler/GHC/Core/Make.hs +0/−1
- compiler/GHC/Core/Opt/Arity.hs +2/−2
- compiler/GHC/Core/Opt/ConstantFold.hs +67/−69
- compiler/GHC/Core/PatSyn.hs +5/−0
- compiler/GHC/Core/Predicate.hs +60/−1
- compiler/GHC/Core/TyCon.hs +193/−45
- compiler/GHC/Core/Type.hs +80/−43
- compiler/GHC/Core/Type.hs-boot +1/−0
- compiler/GHC/Core/Unfold.hs +3/−88
- compiler/GHC/Core/Unfold/Make.hs +91/−1
- compiler/GHC/Core/Unify.hs +14/−2
- compiler/GHC/Core/Utils.hs +2/−43
- compiler/GHC/CoreToIface.hs +2/−2
- compiler/GHC/Data/Bag.hs +8/−2
- compiler/GHC/Data/FastString.hs +10/−2
- compiler/GHC/Data/List/SetOps.hs +11/−1
- compiler/GHC/Data/StringBuffer.hs +57/−1
- compiler/GHC/Driver/Backpack/Syntax.hs +1/−1
- compiler/GHC/Driver/Config/Finder.hs +0/−26
- compiler/GHC/Driver/Env/KnotVars.hs +35/−2
- compiler/GHC/Driver/Flags.hs +5/−3
- compiler/GHC/Driver/Pipeline/Monad.hs +0/−40
- compiler/GHC/Driver/Plugins.hs +9/−0
- compiler/GHC/Driver/Session.hs +34/−66
- compiler/GHC/Hs.hs +1/−1
- compiler/GHC/Hs/Dump.hs +3/−1
- compiler/GHC/Hs/Expr.hs +13/−7
- compiler/GHC/Hs/Extension.hs +6/−6
- compiler/GHC/Hs/ImpExp.hs +14/−11
- compiler/GHC/Hs/Instances.hs +2/−0
- compiler/GHC/Hs/Utils.hs +3/−8
- compiler/GHC/HsToCore/Errors/Ppr.hs +0/−35
- compiler/GHC/HsToCore/Errors/Types.hs +0/−18
- compiler/GHC/Iface/Syntax.hs +8/−8
- compiler/GHC/Iface/Type.hs +43/−16
- compiler/GHC/Linker/Types.hs +2/−2
- compiler/GHC/Parser/Annotation.hs +61/−23
- compiler/GHC/Parser/Errors/Ppr.hs +17/−0
- compiler/GHC/Parser/Errors/Types.hs +10/−0
- compiler/GHC/Parser/Header.hs +10/−9
- compiler/GHC/Parser/PostProcess.hs +91/−60
- compiler/GHC/Parser/PostProcess/Haddock.hs +2/−2
- compiler/GHC/Platform.hs +1/−3
- compiler/GHC/Runtime/Context.hs +78/−19
- compiler/GHC/Runtime/Eval/Types.hs +17/−8
- compiler/GHC/Runtime/Interpreter.hs +7/−2
- compiler/GHC/Settings.hs +0/−9
- compiler/GHC/Stg/Syntax.hs +3/−0
- compiler/GHC/Tc/Errors/Hole/FitTypes.hs +6/−1
- compiler/GHC/Tc/Errors/Ppr.hs +532/−50
- compiler/GHC/Tc/Errors/Types.hs +535/−23
- compiler/GHC/Tc/Solver/InertSet.hs +5/−1
- compiler/GHC/Tc/Solver/Types.hs +5/−3
- compiler/GHC/Tc/Types.hs +38/−1
- compiler/GHC/Tc/Types/Constraint.hs +15/−0
- compiler/GHC/Tc/Types/Evidence.hs +8/−86
- compiler/GHC/Tc/Types/Origin.hs +345/−7
- compiler/GHC/Tc/Utils/TcType.hs +3/−2
- compiler/GHC/Tc/Utils/TcType.hs-boot +4/−0
- compiler/GHC/Types/Basic.hs +66/−0
- compiler/GHC/Types/BreakInfo.hs +12/−0
- compiler/GHC/Types/Demand.hs +527/−226
- compiler/GHC/Types/Error.hs +1/−0
- compiler/GHC/Types/Hint.hs +44/−4
- compiler/GHC/Types/Hint/Ppr.hs +6/−0
- compiler/GHC/Types/Id.hs +3/−24
- compiler/GHC/Types/Id/Info.hs +18/−14
- compiler/GHC/Types/Id/Make.hs +29/−16
- compiler/GHC/Types/Literal.hs +3/−1
- compiler/GHC/Types/Name.hs +1/−5
- compiler/GHC/Types/Name/Occurrence.hs +11/−2
- compiler/GHC/Types/Name/Reader.hs +37/−49
- compiler/GHC/Types/PkgQual.hs +40/−0
- compiler/GHC/Types/Target.hs +8/−6
- compiler/GHC/Types/Unique.hs +1/−8
- compiler/GHC/Types/Unique/DFM.hs +12/−4
- compiler/GHC/Types/Unique/FM.hs +13/−3
- compiler/GHC/Types/Var/Env.hs +22/−2
- compiler/GHC/Unit.hs +2/−6
- compiler/GHC/Unit/Finder.hs +0/−655
- compiler/GHC/Unit/Finder/Types.hs +34/−0
- compiler/GHC/Unit/Home.hs +1/−1
- compiler/GHC/Unit/Home/ModInfo.hs +7/−1
- compiler/GHC/Unit/Info.hs +2/−5
- compiler/GHC/Unit/Module.hs +1/−1
- compiler/GHC/Unit/Module/Deps.hs +12/−1
- compiler/GHC/Unit/Module/Graph.hs +11/−12
- compiler/GHC/Unit/Module/Location.hs +31/−2
- compiler/GHC/Unit/Module/ModIface.hs +45/−3
- compiler/GHC/Unit/Module/ModSummary.hs +20/−17
- compiler/GHC/Unit/Parser.hs +2/−7
- compiler/GHC/Unit/State.hs +34/−33
- compiler/GHC/Unit/Types.hs +14/−24
- compiler/GHC/Unit/Types.hs-boot +0/−2
- compiler/GHC/Utils/Error.hs +12/−9
- compiler/GHC/Utils/Misc.hs +27/−10
- compiler/Language/Haskell/Syntax/Expr.hs +29/−9
- ghc-lib-parser.cabal +9/−9
- ghc-lib/stage0/compiler/build/GHC/Parser.hs +47/−46
- ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs +3/−4
- ghc-lib/stage0/lib/ghcautoconf.h +4/−1
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- libraries/ghc-boot/GHC/Unit/Database.hs +10/−9
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/GHC/Builtin/Names.hs view
@@ -367,15 +367,7 @@ integerMulName, integerSubName, integerNegateName,- integerEqName,- integerNeName,- integerLeName,- integerGtName,- integerLtName,- integerGeName, integerAbsName,- integerSignumName,- integerCompareName, integerPopCountName, integerQuotName, integerRemName,@@ -397,14 +389,6 @@ integerShiftRName, naturalToWordName,- naturalToWordClampName,- naturalEqName,- naturalNeName,- naturalGeName,- naturalLeName,- naturalGtName,- naturalLtName,- naturalCompareName, naturalPopCountName, naturalShiftRName, naturalShiftLName,@@ -413,8 +397,6 @@ naturalSubThrowName, naturalSubUnsafeName, naturalMulName,- naturalSignumName,- naturalNegateName, naturalQuotRemName, naturalQuotName, naturalRemName,@@ -433,6 +415,7 @@ naturalSizeInBaseName, bignatFromWordListName,+ bignatEqName, -- Float/Double integerToFloatName,@@ -1166,15 +1149,7 @@ , integerMulName , integerSubName , integerNegateName- , integerEqName- , integerNeName- , integerLeName- , integerGtName- , integerLtName- , integerGeName , integerAbsName- , integerSignumName- , integerCompareName , integerPopCountName , integerQuotName , integerRemName@@ -1195,14 +1170,6 @@ , integerShiftLName , integerShiftRName , naturalToWordName- , naturalToWordClampName- , naturalEqName- , naturalNeName- , naturalGeName- , naturalLeName- , naturalGtName- , naturalLtName- , naturalCompareName , naturalPopCountName , naturalShiftRName , naturalShiftLName@@ -1211,8 +1178,6 @@ , naturalSubThrowName , naturalSubUnsafeName , naturalMulName- , naturalSignumName- , naturalNegateName , naturalQuotRemName , naturalQuotName , naturalRemName@@ -1230,6 +1195,9 @@ , naturalPowModName , naturalSizeInBaseName , bignatFromWordListName+ , bignatEqName+ , bignatCompareName+ , bignatCompareWordName :: Name bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name@@ -1239,16 +1207,11 @@ -- Types and DataCons bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey+bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey+bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey+bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey-naturalToWordClampName = bnnVarQual "naturalToWordClamp#" naturalToWordClampIdKey-naturalEqName = bnnVarQual "naturalEq#" naturalEqIdKey-naturalNeName = bnnVarQual "naturalNe#" naturalNeIdKey-naturalGeName = bnnVarQual "naturalGe#" naturalGeIdKey-naturalLeName = bnnVarQual "naturalLe#" naturalLeIdKey-naturalGtName = bnnVarQual "naturalGt#" naturalGtIdKey-naturalLtName = bnnVarQual "naturalLt#" naturalLtIdKey-naturalCompareName = bnnVarQual "naturalCompare" naturalCompareIdKey naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey@@ -1257,8 +1220,6 @@ naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey-naturalSignumName = bnnVarQual "naturalSignum" naturalSignumIdKey-naturalNegateName = bnnVarQual "naturalNegate" naturalNegateIdKey naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey@@ -1291,15 +1252,7 @@ integerMulName = bniVarQual "integerMul" integerMulIdKey integerSubName = bniVarQual "integerSub" integerSubIdKey integerNegateName = bniVarQual "integerNegate" integerNegateIdKey-integerEqName = bniVarQual "integerEq#" integerEqIdKey-integerNeName = bniVarQual "integerNe#" integerNeIdKey-integerLeName = bniVarQual "integerLe#" integerLeIdKey-integerGtName = bniVarQual "integerGt#" integerGtIdKey-integerLtName = bniVarQual "integerLt#" integerLtIdKey-integerGeName = bniVarQual "integerGe#" integerGeIdKey integerAbsName = bniVarQual "integerAbs" integerAbsIdKey-integerSignumName = bniVarQual "integerSignum" integerSignumIdKey-integerCompareName = bniVarQual "integerCompare" integerCompareIdKey integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey integerQuotName = bniVarQual "integerQuot" integerQuotIdKey integerRemName = bniVarQual "integerRem" integerRemIdKey@@ -1885,7 +1838,8 @@ typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey,- compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique+ compactPrimTyConKey, stackSnapshotPrimTyConKey,+ concretePrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52@@ -1914,6 +1868,7 @@ tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80 stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81+concretePrimTyConKey = mkPreludeTyConUnique 82 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84@@ -2253,7 +2208,6 @@ naturalNSDataConKey = mkPreludeDataConUnique 123 naturalNBDataConKey = mkPreludeDataConUnique 124 - ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES DataUniques 200-250 -----------------------------------------------------@@ -2564,15 +2518,7 @@ , integerMulIdKey , integerSubIdKey , integerNegateIdKey- , integerEqIdKey- , integerNeIdKey- , integerLeIdKey- , integerGtIdKey- , integerLtIdKey- , integerGeIdKey , integerAbsIdKey- , integerSignumIdKey- , integerCompareIdKey , integerPopCountIdKey , integerQuotIdKey , integerRemIdKey@@ -2596,14 +2542,6 @@ , integerFromWord64IdKey , integerFromInt64IdKey , naturalToWordIdKey- , naturalToWordClampIdKey- , naturalEqIdKey- , naturalNeIdKey- , naturalGeIdKey- , naturalLeIdKey- , naturalGtIdKey- , naturalLtIdKey- , naturalCompareIdKey , naturalPopCountIdKey , naturalShiftRIdKey , naturalShiftLIdKey@@ -2612,8 +2550,6 @@ , naturalSubThrowIdKey , naturalSubUnsafeIdKey , naturalMulIdKey- , naturalSignumIdKey- , naturalNegateIdKey , naturalQuotRemIdKey , naturalQuotIdKey , naturalRemIdKey@@ -2631,6 +2567,9 @@ , naturalPowModIdKey , naturalSizeInBaseIdKey , bignatFromWordListIdKey+ , bignatEqIdKey+ , bignatCompareIdKey+ , bignatCompareWordIdKey :: Unique integerFromNaturalIdKey = mkPreludeMiscIdUnique 600@@ -2645,15 +2584,7 @@ integerMulIdKey = mkPreludeMiscIdUnique 609 integerSubIdKey = mkPreludeMiscIdUnique 610 integerNegateIdKey = mkPreludeMiscIdUnique 611-integerEqIdKey = mkPreludeMiscIdUnique 612-integerNeIdKey = mkPreludeMiscIdUnique 613-integerLeIdKey = mkPreludeMiscIdUnique 614-integerGtIdKey = mkPreludeMiscIdUnique 615-integerLtIdKey = mkPreludeMiscIdUnique 616-integerGeIdKey = mkPreludeMiscIdUnique 617 integerAbsIdKey = mkPreludeMiscIdUnique 618-integerSignumIdKey = mkPreludeMiscIdUnique 619-integerCompareIdKey = mkPreludeMiscIdUnique 620 integerPopCountIdKey = mkPreludeMiscIdUnique 621 integerQuotIdKey = mkPreludeMiscIdUnique 622 integerRemIdKey = mkPreludeMiscIdUnique 623@@ -2678,14 +2609,6 @@ integerFromInt64IdKey = mkPreludeMiscIdUnique 644 naturalToWordIdKey = mkPreludeMiscIdUnique 650-naturalToWordClampIdKey = mkPreludeMiscIdUnique 651-naturalEqIdKey = mkPreludeMiscIdUnique 652-naturalNeIdKey = mkPreludeMiscIdUnique 653-naturalGeIdKey = mkPreludeMiscIdUnique 654-naturalLeIdKey = mkPreludeMiscIdUnique 655-naturalGtIdKey = mkPreludeMiscIdUnique 656-naturalLtIdKey = mkPreludeMiscIdUnique 657-naturalCompareIdKey = mkPreludeMiscIdUnique 658 naturalPopCountIdKey = mkPreludeMiscIdUnique 659 naturalShiftRIdKey = mkPreludeMiscIdUnique 660 naturalShiftLIdKey = mkPreludeMiscIdUnique 661@@ -2694,8 +2617,6 @@ naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 naturalMulIdKey = mkPreludeMiscIdUnique 666-naturalSignumIdKey = mkPreludeMiscIdUnique 667-naturalNegateIdKey = mkPreludeMiscIdUnique 668 naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 naturalQuotIdKey = mkPreludeMiscIdUnique 670 naturalRemIdKey = mkPreludeMiscIdUnique 671@@ -2714,7 +2635,11 @@ naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 bignatFromWordListIdKey = mkPreludeMiscIdUnique 690+bignatEqIdKey = mkPreludeMiscIdUnique 691+bignatCompareIdKey = mkPreludeMiscIdUnique 692+bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 + ------------------------------------------------------ -- ghci optimization for big rationals 700-749 uniques ------------------------------------------------------@@ -2794,17 +2719,41 @@ * * ************************************************************************ -GHCi's :info command will usually filter out instances mentioning types whose-names are not in scope. GHCi makes an exception for some commonly used names,-such as Data.Kind.Type, which may not actually be in scope but should be-treated as though they were in scope. The list in the definition of-pretendNameIsInScope below contains these commonly used names.+Note [pretendNameIsInScope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we filter out instances that mention types whose names are+not in scope. However, in the situations listed below, we make an exception+for some commonly used names, such as Data.Kind.Type, which may not actually+be in scope but should be treated as though they were in scope.+This includes built-in names, as well as a few extra names such as+'Type', 'TYPE', 'BoxedRep', etc. +Situations in which we apply this special logic:++ - GHCi's :info command, see GHC.Runtime.Eval.getInfo.+ This fixes #1581.++ - When reporting instance overlap errors. Not doing so could mean+ that we would omit instances for typeclasses like++ type Cls :: k -> Constraint+ class Cls a++ because BoxedRep/Lifted were not in scope.+ See GHC.Tc.Errors.pprPotentials.+ This fixes one of the issues reported in #20465. -} +-- | Should this name be considered in-scope, even though it technically isn't?+--+-- This ensures that we don't filter out information because, e.g.,+-- Data.Kind.Type isn't imported.+--+-- See Note [pretendNameIsInScope]. pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n- = any (n `hasKey`)+ = isBuiltInSyntax n+ || any (n `hasKey`) [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey , liftedDataConKey, unliftedDataConKey , tYPETyConKey
compiler/GHC/Builtin/PrimOps.hs view
@@ -38,7 +38,7 @@ import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import GHC.Core.Type import GHC.Types.RepType ( tyConPrimRep1 )-import GHC.Types.Basic ( Arity, Boxity(..) )+import GHC.Types.Basic ( Arity ) import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString )@@ -692,7 +692,7 @@ convention for curried applications that can accommodate representation polymorphism. -To ensure saturation, CorePrep eta expands expand all primop applications as+To ensure saturation, CorePrep eta expands all primop applications as described in Note [Eta expansion of hasNoBinding things in CorePrep] in GHC.Core.Prep.
compiler/GHC/Builtin/Types/Prim.hs view
@@ -102,6 +102,8 @@ eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) equalityTyCon, + concretePrimTyCon,+ -- * SIMD #include "primop-vector-tys-exports.hs-incl" ) where@@ -164,6 +166,7 @@ = [ eqPrimTyCon , eqReprPrimTyCon , eqPhantPrimTyCon+ , concretePrimTyCon ] -- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim.@@ -227,7 +230,19 @@ BuiltInSyntax -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, stackSnapshotPrimTyConName :: Name+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName,+ wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName,+ addrPrimTyConName, floatPrimTyConName, doublePrimTyConName,+ statePrimTyConName, proxyPrimTyConName, realWorldTyConName,+ arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName,+ mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName,+ smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,+ ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName,+ stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,+ weakPrimTyConName, threadIdPrimTyConName,+ eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,+ stackSnapshotPrimTyConName,+ concretePrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -273,6 +288,7 @@ weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon+concretePrimTyConName = mkPrimTc (fsLit "Concrete#") concretePrimTyConKey concretePrimTyCon {- ************************************************************************@@ -1031,6 +1047,25 @@ equalityTyCon Nominal = eqPrimTyCon equalityTyCon Representational = eqReprPrimTyCon equalityTyCon Phantom = eqPhantPrimTyCon++{- *********************************************************************+* *+ The Concrete mechanism+* *+********************************************************************* -}++-- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.++-- type Concrete# :: forall k. k -> TYPE (TupleRep '[])++concretePrimTyCon :: TyCon+concretePrimTyCon =+ mkPrimTyCon concretePrimTyConName binders res_kind roles+ where+ -- Kind :: forall k. k -> TYPE (TupleRep '[])+ binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k])+ res_kind = unboxedTupleKind []+ roles = [Nominal, Nominal] {- ********************************************************************* * *
compiler/GHC/Builtin/Uniques.hs view
@@ -29,16 +29,13 @@ , mkPrimOpIdUnique, mkPrimOpWrapperUnique , mkPreludeMiscIdUnique, mkPreludeDataConUnique , mkPreludeTyConUnique, mkPreludeClassUnique- , mkCoVarUnique , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique , mkCostCentreUnique , mkBuiltinUnique- , mkPseudoUniqueD , mkPseudoUniqueE- , mkPseudoUniqueH -- ** Deriving uniquesc -- *** From TyCon name uniques@@ -46,7 +43,6 @@ -- *** From DataCon name uniques , dataConWorkerUnique, dataConTyRepNameUnique - , initTyVarUnique , initExitJoinUnique ) where@@ -290,7 +286,7 @@ Note [Uniques for wired-in prelude things and known masks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Allocation of unique supply characters:- v,t,u : for renumbering value-, type- and usage- vars.+ v,u: for renumbering value-, and usage- vars. B: builtin C-E: pseudo uniques (used in native-code generator) I: GHCi evaluation@@ -306,7 +302,6 @@ c StgToCmm/Renamer d desugarer f AbsC flattener- g SimplStg i TypeChecking interface files j constraint tuple superclass selectors k constraint tuple tycons@@ -325,10 +320,8 @@ -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. mkPrimOpWrapperUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique-mkCoVarUnique :: Int -> Unique mkAlphaTyVarUnique i = mkUnique '1' i-mkCoVarUnique i = mkUnique 'g' i mkPreludeClassUnique i = mkUnique '2' i --------------------------------------------------@@ -336,19 +329,10 @@ mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) mkPreludeMiscIdUnique i = mkUnique '0' i --- The "tyvar uniques" print specially nicely: a, b, c, etc.--- See pprUnique for details--initTyVarUnique :: Unique-initTyVarUnique = mkUnique 't' 0--mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,- mkBuiltinUnique :: Int -> Unique+mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique mkBuiltinUnique i = mkUnique 'B' i-mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs-mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique mkRegSingleUnique = mkUnique 'R'@@ -388,7 +372,7 @@ -- * u+2: the TyConRepName of the promoted TyCon -- Prelude data constructors are too simple to need wrappers. -mkPreludeDataConUnique :: Arity -> Unique+mkPreludeDataConUnique :: Int -> Unique mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic --------------------------------------------------
compiler/GHC/Builtin/Uniques.hs-boot view
@@ -23,18 +23,16 @@ mkPrimOpIdUnique :: Int -> Unique mkPrimOpWrapperUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique-mkCoVarUnique :: Int -> Unique -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,- mkBuiltinUnique :: Int -> Unique+mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique -initExitJoinUnique, initTyVarUnique :: Unique+initExitJoinUnique :: Unique mkPreludeTyConUnique :: Int -> Unique tyConRepNameUnique :: Unique -> Unique -mkPreludeDataConUnique :: Arity -> Unique+mkPreludeDataConUnique :: Int -> Unique dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
compiler/GHC/Cmm/MachOp.hs view
@@ -669,9 +669,11 @@ | MO_AtomicRMW Width AtomicMachOp | MO_AtomicRead Width | MO_AtomicWrite Width+ -- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@.+ -- Sequentially consistent.+ -- Possible future refactoring: should this be an'MO_AtomicRMW' variant? | MO_Cmpxchg Width- -- Should be an AtomicRMW variant eventually.- -- Sequential consistent.+ -- | Atomic swap. Arguments are @[dest, new]@ | MO_Xchg Width -- These rts provided functions are special: suspendThread releases the
compiler/GHC/CmmToAsm/Config.hs view
@@ -45,6 +45,7 @@ , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump) , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables+ , ncgEnableDeadCodeElimination :: !Bool -- ^ Whether to enable the dead-code elimination } -- | Return Word size
compiler/GHC/Core.hs view
@@ -547,30 +547,34 @@ See Note [Case expression invariants] Note [Representation polymorphism invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The representation polymorphism invariants are described as follows,-according to the paper "Levity Polymorphism", PLDI '17.+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC allows us to abstract over calling conventions using **representation polymorphism**.+For example, we have: -* The type of a term-binder must not be representation-polymorphic,- unless it is a let(rec)-bound join point- (see Note [Invariants on join points])+ ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b -* The type of the argument of an App must not be representation-polymorphic.+In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`,+where the type variable `r :: RuntimeRep` abstracts over the runtime representation+of values of type `b`. -A type (t::TYPE r) is "representation-polymorphic" if 'r' has any free variables,-and "levity-polymorphic" if it is of the form (t::TYPE (BoxedRep v))-and 'v' has free variables (levity polymorphism is a special case of-representation polymorphism).-Note that the aforementioned "Levity Polymorphism" paper conflates both these-types of polymorphism; a more precise distinction was only made possible-with the introduction of BoxedRep.+To ensure that programs containing representation-polymorphism remain compilable,+we enforce two invariants (the representation-polymorphism invariants),+as per "Levity Polymorphism" [PLDI'17]: + I1. The type of a bound variable must have a fixed runtime representation+ (except for join points: See Note [Invariants on join points])+ I2. The type of a function argument must have a fixed runtime representation.+ For example \(r::RuntimeRep). \(a::TYPE r). \(x::a). e is illegal because x's type has kind (TYPE r), which has 'r' free.+We thus wouldn't know how to compile this lambda abstraction. -See Note [Representation polymorphism checking] in GHC.HsToCore.Monad to see where these-invariants are established for user-written code.+In practice, we currently require something slightly stronger than a fixed runtime+representation: we check whether bound variables and function arguments have a+/fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+for an overview of how we enforce these invariants in the typechecker. Note [Core let goal] ~~~~~~~~~~~~~~~~~~~~@@ -712,7 +716,7 @@ ok-for-speculation (i.e. drop the let/app invariant) e.g. let j :: Int# = factorial x in ... - 6. A join point can have a representation-polymorphic RHS+ 6. The RHS of join point is not required to have a fixed runtime representation, e.g. let j :: r :: TYPE l = fail void# in ... This happened in an intermediate program #13394 @@ -942,7 +946,7 @@ -- See Note [Orphans] data IsOrphan = IsOrphan- | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood+ | NotOrphan !OccName -- The OccName 'n' witnesses the instance's non-orphanhood -- In that case, the instance is fingerprinted as part -- of the definition of 'n's definition deriving Data@@ -1127,6 +1131,8 @@ , roBignumRules :: !Bool -- ^ Enable rules for bignums } +-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are+-- currently in scope. See Note [The InScopeSet invariant]. type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr type InScopeEnv = (InScopeSet, IdUnfoldingFun)
compiler/GHC/Core/ConLike.hs view
@@ -9,6 +9,7 @@ module GHC.Core.ConLike ( ConLike(..)+ , isVanillaConLike , conLikeArity , conLikeFieldLabels , conLikeInstOrigArgTys@@ -53,6 +54,12 @@ -- | A constructor-like thing data ConLike = RealDataCon DataCon | PatSynCon PatSyn++-- | Is this a \'vanilla\' constructor-like thing+-- (no existentials, no provided constraints)?+isVanillaConLike :: ConLike -> Bool+isVanillaConLike (RealDataCon con) = isVanillaDataCon con+isVanillaConLike (PatSynCon ps ) = isVanillaPatSyn ps {- ************************************************************************
compiler/GHC/Core/Lint.hs view
@@ -174,7 +174,7 @@ let a = Type Bool in let x::a = True in <body> That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core".-One place it is used is in mkWwArgs; see Note [Join points and beta-redexes]+One place it is used is in mkWorkerArgs; see Note [Join points and beta-redexes] in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). * Hence when linting <body> we need to remember that a=Int, else we@@ -480,17 +480,17 @@ , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity- , lf_check_levity_poly = check_levity }+ , lf_check_fixed_rep = check_fixed_rep } -- In the output of the desugarer, before optimisation, -- we have eta-expanded data constructors with representation-polymorphic- -- bindings; so we switch off the lev-poly checks. The very simple- -- optimiser will beta-reduce them away.+ -- bindings; so we switch off the representation-polymorphism checks.+ -- The very simple optimiser will beta-reduce them away. -- See Note [Checking representation-polymorphic data constructors] -- in GHC.HsToCore.Expr.- check_levity = case pass of- CoreDesugar -> False- _ -> True+ check_fixed_rep = case pass of+ CoreDesugar -> False+ _ -> True -- See Note [Checking for global Ids] check_globals = case pass of@@ -565,7 +565,7 @@ (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ if is_compulsory -- See Note [Checking for representation polymorphism]- then noLPChecks linter+ then noFixedRuntimeRepChecks linter else linter linter = addLoc (ImportedUnfolding locn) $ lintCoreExpr expr@@ -749,8 +749,8 @@ | isStableUnfolding uf , Just rhs <- maybeUnfoldingTemplate uf = do { ty <- fst <$> (if isCompulsoryUnfolding uf- then noLPChecks $ lintRhs bndr rhs- -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+ then noFixedRuntimeRepChecks $ lintRhs bndr rhs+ -- ^^^^^^^^^^^^^^^^^^^^^^^ -- See Note [Checking for representation polymorphism] else lintRhs bndr rhs) ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }@@ -1191,11 +1191,11 @@ -- See Note [Representation polymorphism invariants] in GHC.Core ; flags <- getLintFlags - ; when (lf_check_levity_poly flags) $- -- Only do these checks if lf_check_levity_poly is on,+ ; when (lf_check_fixed_rep flags) $+ -- Only do these checks if lf_check_fixed_rep is on, -- because otherwise isUnliftedType panics- do { checkL (not (isTypeLevPoly arg_ty))- (text "Representation-polymorphic argument:"+ do { checkL (typeHasFixedRuntimeRep arg_ty)+ (text "Argument does not have a fixed runtime representation" <+> ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) @@ -1550,9 +1550,9 @@ (mkNonTopExternalNameMsg id) -- See Note [Representation polymorphism invariants] in GHC.Core- ; lintL (isJoinId id || not (lf_check_levity_poly flags)- || not (isTypeLevPoly id_ty)) $- text "Representation-polymorphic binder:" <+> ppr id <+> dcolon <+>+ ; lintL (isJoinId id || not (lf_check_fixed_rep flags)+ || typeHasFixedRuntimeRep id_ty) $+ text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) -- Check that a join-id is a not-top-level let-binding@@ -2121,17 +2121,17 @@ | allow_ill_kinded_univ_co prov = return () -- Skip kind checks | otherwise- = do { checkWarnL (not lev_poly1)- (report "left-hand type is representation-polymorphic")- ; checkWarnL (not lev_poly2)- (report "right-hand type is representation-polymorphic")- ; when (not (lev_poly1 || lev_poly2)) $+ = do { checkWarnL fixed_rep_1+ (report "left-hand type does not have a fixed runtime representation")+ ; checkWarnL fixed_rep_2+ (report "right-hand type does not have a fixed runtime representation")+ ; when (fixed_rep_1 && fixed_rep_2) $ do { checkWarnL (reps1 `equalLength` reps2) (report "between values with different # of reps") ; zipWithM_ validateCoercion reps1 reps2 }} where- lev_poly1 = isTypeLevPoly t1- lev_poly2 = isTypeLevPoly t2+ fixed_rep_1 = typeHasFixedRuntimeRep t1+ fixed_rep_2 = typeHasFixedRuntimeRep t2 -- don't look at these unless lev_poly1/2 are False -- Otherwise, we get #13458@@ -2559,7 +2559,7 @@ , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] , lf_check_linearity :: Bool -- ^ See Note [Linting linearity]- , lf_check_levity_poly :: Bool -- See Note [Checking for representation polymorphism]+ , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] } -- See Note [Checking StaticPtrs]@@ -2578,7 +2578,7 @@ , lf_check_static_ptrs = AllowAnywhere , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags , lf_report_unsat_syns = True- , lf_check_levity_poly = True+ , lf_check_fixed_rep = True } newtype LintM a =@@ -2737,10 +2737,10 @@ in unLintM thing_inside env' errs -- See Note [Checking for representation polymorphism]-noLPChecks :: LintM a -> LintM a-noLPChecks thing_inside+noFixedRuntimeRepChecks :: LintM a -> LintM a+noFixedRuntimeRepChecks thing_inside = LintM $ \env errs ->- let env' = env { le_flags = (le_flags env) { lf_check_levity_poly = False } }+ let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } in unLintM thing_inside env' errs getLintFlags :: LintM LintFlags
compiler/GHC/Core/Make.hs view
@@ -65,7 +65,6 @@ import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal import GHC.Types.Unique.Supply-import GHC.Types.Basic import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
compiler/GHC/Core/Opt/Arity.hs view
@@ -1591,7 +1591,7 @@ ----------- Function types (t1 -> t2) | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty- , not (isTypeLevPoly arg_ty)+ , typeHasFixedRuntimeRep arg_ty -- See Note [Representation polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly @@ -1621,7 +1621,7 @@ | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder- -- is representation-polymorphic+ -- does not have a fixed runtime representation = warnPprTrace True ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) (getTCvInScope subst, EI [] MRefl) -- This *can* legitimately happen:
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -157,6 +157,7 @@ Word8AndOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.)) , idempotent , zeroElem+ , identity (mkLitWord8 0xFF) , sameArgIdempotentCommut Word8AndOp , andFoldingRules word8Ops ]@@ -230,6 +231,7 @@ Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.)) , idempotent , zeroElem+ , identity (mkLitWord16 0xFFFF) , sameArgIdempotentCommut Word16AndOp , andFoldingRules word16Ops ]@@ -303,6 +305,7 @@ Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.)) , idempotent , zeroElem+ , identity (mkLitWord32 0xFFFFFFFF) , sameArgIdempotentCommut Word32AndOp , andFoldingRules word32Ops ]@@ -375,6 +378,7 @@ Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.)) , idempotent , zeroElem+ , identity (mkLitWord64 0xFFFFFFFFFFFFFFFF) , sameArgIdempotentCommut Word64AndOp , andFoldingRules word64Ops ]@@ -456,6 +460,7 @@ IntAndOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) , idempotent , zeroElem+ , identityPlatform (\p -> mkLitInt p (-1)) , sameArgIdempotentCommut IntAndOp , andFoldingRules intOps ]@@ -507,6 +512,7 @@ WordAndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) , idempotent , zeroElem+ , identityPlatform (\p -> mkLitWord p (platformMaxWord p)) , sameArgIdempotentCommut WordAndOp , andFoldingRules wordOps ]@@ -1325,15 +1331,12 @@ -- and return the innermost (op v e) or (op e v). sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr sameArgIdempotentCommut op = do- let is_op = \case- BinOpApp v op' e | op == op' -> Just (v,e)- _ -> Nothing [a,b] <- getArgs case (a,b) of- (is_op -> Just (e1,e2), e3)+ (is_binop op -> Just (e1,e2), e3) | cheapEqExpr e2 e3 -> return a | cheapEqExpr e1 e3 -> return a- (e3, is_op -> Just (e1,e2))+ (e3, is_binop op -> Just (e1,e2)) | cheapEqExpr e2 e3 -> return b | cheapEqExpr e1 e3 -> return b _ -> mzero@@ -1511,9 +1514,9 @@ Nothing -> mzero Just l -> pure l --- | Match Integer and Natural literals+-- | Match BigNat#, Integer and Natural literals isBignumLiteral :: CoreExpr -> RuleM Integer-isBignumLiteral e = isIntegerLiteral e <|> isNaturalLiteral e+isBignumLiteral e = isNumberLiteral e <|> isIntegerLiteral e <|> isNaturalLiteral e -- | Match numeric literals isNumberLiteral :: CoreExpr -> RuleM Integer@@ -2049,27 +2052,14 @@ , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False - , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False- , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True+ , natural_to_word "Natural -> Word# (wrap)" naturalToWordName -- comparisons (return an unlifted Int#)- , integer_cmp "integerEq#" integerEqName (==)- , integer_cmp "integerNe#" integerNeName (/=)- , integer_cmp "integerLe#" integerLeName (<=)- , integer_cmp "integerGt#" integerGtName (>)- , integer_cmp "integerLt#" integerLtName (<)- , integer_cmp "integerGe#" integerGeName (>=)-- , natural_cmp "naturalEq#" naturalEqName (==)- , natural_cmp "naturalNe#" naturalNeName (/=)- , natural_cmp "naturalLe#" naturalLeName (<=)- , natural_cmp "naturalGt#" naturalGtName (>)- , natural_cmp "naturalLt#" naturalLtName (<)- , natural_cmp "naturalGe#" naturalGeName (>=)+ , bignum_bin_pred "bigNatEq#" bignatEqName (==) -- comparisons (return an Ordering)- , bignum_compare "integerCompare" integerCompareName- , bignum_compare "naturalCompare" naturalCompareName+ , bignum_compare "bignatCompare" bignatCompareName+ , bignum_compare "bignatCompareWord#" bignatCompareWordName -- binary operations , integer_binop "integerAdd" integerAddName (+)@@ -2107,28 +2097,11 @@ -- unary operations , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs- , bignum_unop "integerSignum" integerSignumName mkIntegerExpr signum , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement - , bignum_unop "naturalSignum" naturalSignumName mkNaturalExpr signum-- , mkRule "naturalNegate" naturalNegateName 1 $ do- [a0] <- getArgs- x <- isNaturalLiteral a0- guard (x == 0) -- negate is only valid for (0 :: Natural)- pure a0- , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap - ------------------------------------------------------------- -- The following `small_passthough_*` rules are used to optimise conversions- -- between numeric types by avoiding passing through "small" constructors of- -- Integer and Natural.- --- -- See Note [Optimising conversions between numeric types]- --- -- Bits.bit , bignum_bit "integerBit" integerBitName mkIntegerExpr , bignum_bit "naturalBit" naturalBitName mkNaturalExpr@@ -2182,13 +2155,11 @@ x <- isBigIntegerLiteral a0 pure (convert platform x) - natural_to_word str name clamp = mkRule str name 1 $ do+ natural_to_word str name = mkRule str name 1 $ do [a0] <- getArgs n <- isNaturalLiteral a0 platform <- getPlatform- if clamp && not (platformInWordRange platform n)- then pure (Lit (mkLitWord platform (platformMaxWord platform)))- else pure (Lit (mkLitWordWrap platform n))+ pure (Lit (mkLitWordWrap platform n)) integer_to_natural str name thrw clamp = mkRule str name 1 $ do [a0] <- getArgs@@ -2202,7 +2173,7 @@ lit_to_integer str name = mkRule str name 1 $ do [a0] <- getArgs platform <- getPlatform- i <- isNumberLiteral a0 <|> isBignumLiteral a0+ i <- isBignumLiteral a0 -- convert any numeric literal into an Integer literal pure (mkIntegerExpr platform i) @@ -2228,20 +2199,11 @@ platform <- getPlatform pure (mkNaturalExpr platform (x - y)) - integer_cmp str name op = mkRule str name 2 $ do- platform <- getPlatform- [a0,a1] <- getArgs- x <- isIntegerLiteral a0- y <- isIntegerLiteral a1- pure $ if x `op` y- then trueValInt platform- else falseValInt platform-- natural_cmp str name op = mkRule str name 2 $ do+ bignum_bin_pred str name op = mkRule str name 2 $ do platform <- getPlatform [a0,a1] <- getArgs- x <- isNaturalLiteral a0- y <- isNaturalLiteral a1+ x <- isBignumLiteral a0+ y <- isBignumLiteral a1 pure $ if x `op` y then trueValInt platform else falseValInt platform@@ -2689,6 +2651,11 @@ addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of++ -- x + (-y) ==> x-y+ (x, is_neg num_ops -> Just y)+ -> Just (x `sub` y)+ -- R1) +/- simplification -- l1 + (l2 + x) ==> (l1+l2) + x@@ -2770,6 +2737,10 @@ subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+ -- x - (-y) ==> x+y+ (x, is_neg num_ops -> Just y)+ -> Just (x `add` y)+ -- R1) +/- simplification -- l1 - (l2 + x) ==> (l1-l2) - x@@ -2887,6 +2858,14 @@ mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+ -- (-x) * (-y) ==> x*y+ (is_neg num_ops -> Just x, is_neg num_ops -> Just y)+ -> Just (x `mul` y)++ -- l1 * (-x) ==> (-l1) * x+ (L l1, is_neg num_ops -> Just x)+ -> Just (mkL (-l1) `mul` x)+ -- l1 * (l2 * x) ==> (l1*l2) * x (L l1, is_lit_mul num_ops -> Just (l2,x)) -> Just (mkL (l1*l2) `mul` x)@@ -2960,18 +2939,26 @@ mkL = Lit . mkNumLiteral platform num_ops or x y = BinOpApp x (fromJust (numOr num_ops)) y -is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)-is_op op e = case e of+is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_binop op e = case e of BinOpApp x op' y | op == op' -> Just (x,y) _ -> Nothing +is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)+is_op op e = case e of+ App (OpVal op') x | op == op' -> Just x+ _ -> Nothing+ is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)-is_add num_ops = is_op (numAdd num_ops)-is_sub num_ops = is_op (numSub num_ops)-is_mul num_ops = is_op (numMul num_ops)-is_and num_ops = is_op (fromJust (numAnd num_ops))-is_or num_ops = is_op (fromJust (numOr num_ops))+is_add num_ops e = is_binop (numAdd num_ops) e+is_sub num_ops e = is_binop (numSub num_ops) e+is_mul num_ops e = is_binop (numMul num_ops) e+is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e+is_or num_ops e = numOr num_ops >>= \op -> is_binop op e +is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)+is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e+ -- match operation with a literal (handles commutativity) is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr) is_lit_add num_ops e = is_lit' is_add num_ops e@@ -3013,12 +3000,13 @@ -- | Explicit "type-class"-like dictionary for numeric primops data NumOps = NumOps- { numAdd :: !PrimOp -- ^ Add two numbers- , numSub :: !PrimOp -- ^ Sub two numbers- , numMul :: !PrimOp -- ^ Multiply two numbers- , numLitType :: !LitNumType -- ^ Literal type+ { numAdd :: !PrimOp -- ^ Add two numbers+ , numSub :: !PrimOp -- ^ Sub two numbers+ , numMul :: !PrimOp -- ^ Multiply two numbers , numAnd :: !(Maybe PrimOp) -- ^ And two numbers , numOr :: !(Maybe PrimOp) -- ^ Or two numbers+ , numNeg :: !(Maybe PrimOp) -- ^ Negate a number+ , numLitType :: !LitNumType -- ^ Literal type } -- | Create a numeric literal@@ -3033,6 +3021,7 @@ , numLitType = LitNumInt8 , numAnd = Nothing , numOr = Nothing+ , numNeg = Just Int8NegOp } word8Ops :: NumOps@@ -3042,6 +3031,7 @@ , numMul = Word8MulOp , numAnd = Just Word8AndOp , numOr = Just Word8OrOp+ , numNeg = Nothing , numLitType = LitNumWord8 } @@ -3053,6 +3043,7 @@ , numLitType = LitNumInt16 , numAnd = Nothing , numOr = Nothing+ , numNeg = Just Int16NegOp } word16Ops :: NumOps@@ -3062,6 +3053,7 @@ , numMul = Word16MulOp , numAnd = Just Word16AndOp , numOr = Just Word16OrOp+ , numNeg = Nothing , numLitType = LitNumWord16 } @@ -3073,6 +3065,7 @@ , numLitType = LitNumInt32 , numAnd = Nothing , numOr = Nothing+ , numNeg = Just Int32NegOp } word32Ops :: NumOps@@ -3082,6 +3075,7 @@ , numMul = Word32MulOp , numAnd = Just Word32AndOp , numOr = Just Word32OrOp+ , numNeg = Nothing , numLitType = LitNumWord32 } @@ -3093,6 +3087,7 @@ , numLitType = LitNumInt64 , numAnd = Nothing , numOr = Nothing+ , numNeg = Just Int64NegOp } word64Ops :: NumOps@@ -3102,6 +3097,7 @@ , numMul = Word64MulOp , numAnd = Just Word64AndOp , numOr = Just Word64OrOp+ , numNeg = Nothing , numLitType = LitNumWord64 } @@ -3112,6 +3108,7 @@ , numMul = IntMulOp , numAnd = Just IntAndOp , numOr = Just IntOrOp+ , numNeg = Just IntNegOp , numLitType = LitNumInt } @@ -3122,6 +3119,7 @@ , numMul = WordMulOp , numAnd = Just WordAndOp , numOr = Just WordOrOp+ , numNeg = Nothing , numLitType = LitNumWord }
compiler/GHC/Core/PatSyn.hs view
@@ -13,6 +13,7 @@ -- ** Type deconstruction patSynName, patSynArity, patSynIsInfix, patSynResultType,+ isVanillaPatSyn, patSynArgs, patSynMatcher, patSynBuilder, patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders,@@ -418,6 +419,10 @@ -- | Arity of the pattern synonym patSynArity :: PatSyn -> Arity patSynArity = psArity++-- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)?+isVanillaPatSyn :: PatSyn -> Bool+isVanillaPatSyn ps = null (psExTyVars ps) && null (psProvTheta ps) patSynArgs :: PatSyn -> [Type] patSynArgs = psArgs
compiler/GHC/Core/Predicate.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DerivingStrategies #-}+ {- Describes predicates as they are considered by the solver.@@ -16,6 +18,9 @@ mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + -- Special predicates+ SpecialPred(..), specialPredTyCon,+ -- Class predicates mkClassPred, isDictTy, isClassPred, isEqPredClass, isCTupleClass,@@ -41,6 +46,7 @@ import GHC.Core.Multiplicity ( scaledThing ) import GHC.Builtin.Names+import GHC.Builtin.Types.Prim ( concretePrimTyCon ) import GHC.Utils.Outputable import GHC.Utils.Misc@@ -51,11 +57,31 @@ -- | A predicate in the solver. The solver tries to prove Wanted predicates -- from Given ones. data Pred++ -- | A typeclass predicate. = ClassPred Class [Type]++ -- | A type equality predicate. | EqPred EqRel Type Type++ -- | An irreducible predicate. | IrredPred PredType++ -- | A quantified predicate.+ --+ -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical | ForAllPred [TyVar] [PredType] PredType- -- ForAllPred: see Note [Quantified constraints] in GHC.Tc.Solver.Canonical++ -- | A special predicate, used internally in GHC.+ --+ -- The meaning of the type argument is dictated by the 'SpecialPred'+ -- specified in the first agument; see the documentation of 'SpecialPred' for more info.+ --+ -- Example: @Concrete# rep@, used for representation-polymorphism checks+ -- within GHC. See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+ -- (This is the only example currently. More to come: see GHC ticket #20000.)+ | SpecialPred SpecialPred Type+ -- NB: There is no TuplePred case -- Tuple predicates like (Eq a, Ord b) are just treated -- as ClassPred, as if we had a tuple class with two superclasses@@ -67,6 +93,10 @@ | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + Just (tc, [_ki, ty])+ | tc `hasKey` concretePrimTyConKey+ -> SpecialPred ConcretePrimPred ty+ Just (tc, tys) | Just clas <- tyConClass_maybe tc -> ClassPred clas tys@@ -160,6 +190,35 @@ = ReprEq | otherwise = NomEq++-- --------------------- Special predicates ----------------------------------++-- | 'SpecialPred' describes all the special predicates+-- that are currently used in GHC.+--+-- These are different from the special typeclasses+-- (such as `KnownNat`, `Typeable`, `Coercible`, ...), as special predicates+-- can't be expressed as typeclasses, as they hold evidence of a different kind.+data SpecialPred+ -- | A @Concrete#@ predicate, to check for representation polymorphism.+ --+ -- When the first argument to the 'SpecialPred' data constructor of 'Pred'+ -- is 'ConcretePrimPred', the second argument is the type we are inspecting+ -- to decide whether it is concrete. That is, it refers to the+ -- second argument of the 'Concrete#' 'TyCon'. Recall that this 'TyCon' has kind+ --+ -- > forall k. k -> TupleRep '[]+ --+ -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for further details.+ = ConcretePrimPred+ deriving stock Eq++instance Outputable SpecialPred where+ ppr ConcretePrimPred = text "Concrete#"++-- | Obtain the 'TyCon' associated with a special predicate.+specialPredTyCon :: SpecialPred -> TyCon+specialPredTyCon ConcretePrimPred = concretePrimTyCon {------------------------------------------- Predicates on PredType
compiler/GHC/Core/TyCon.hs view
@@ -40,6 +40,7 @@ mkTupleTyCon, mkSumTyCon, mkDataTyConRhs,+ mkLevPolyDataTyConRhs, mkSynonymTyCon, mkFamilyTyCon, mkPromotedDataCon,@@ -73,7 +74,8 @@ isImplicitTyCon, isTyConWithSrcDataCons, isTcTyCon, setTcTyConKind,- isTcLevPoly,+ tcHasFixedRuntimeRep,+ isConcreteTyCon, -- ** Extracting information out of TyCons tyConName,@@ -910,8 +912,9 @@ -- e.g. @RealWorld@ -- Only relevant if tyConKind = * - primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons- -- i.e, *, #, ?+ primRepName :: TyConRepName -- ^ The 'Typeable' representation.+ -- A cached version of+ -- @'mkPrelTyConRepName' ('tyConName' tc)@. } -- | Represents promoted data constructor.@@ -1017,6 +1020,86 @@ will include CoVars. That is why we use [TyConTyCoBinder] for the tyconBinders field. TyConTyCoBinder is a synonym for TyConBinder, but with the clue that the binder can be a CoVar not just a TyVar.++Note [Representation-polymorphic TyCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To check for representation-polymorphism directly in the typechecker,+e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep,+we need to compute whether a type has a fixed RuntimeRep,+as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++It's useful to have a quick way to check whether a saturated application+of a type constructor has a fixed RuntimeRep. That is, we want+to know, given a TyCon 'T' of arity 'n', does++ T a_1 ... a_n++always have a fixed RuntimeRep? That is, is it always the case+that this application has a kind of the form++ T a_1 ... a_n :: TYPE rep++in which 'rep' is a concrete 'RuntimeRep'?+('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete:+it contains no type-family applications or type variables.)++To answer this question, we have 'tcHasFixedRuntimeRep'.+If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that+every saturated application of `T` has a fixed RuntimeRep.+However, if it returns 'False', we don't know: perhaps some application might not+have a fixed RuntimeRep.++Examples:++ - For type families, we won't know in general whether an application+ will have a fixed RuntimeRep:++ type F :: k -> k+ type family F a where {..}++ `tcHasFixedRuntimeRep F = False'++ - For newtypes, we're usually OK:++ newtype N a b c = MkN Int++ No matter what arguments we apply `N` to, we always get something of+ kind `Type`, which has a fixed RuntimeRep.+ Thus `tcHasFixedRuntimeRep N = True`.++ However, with `-XUnliftedNewtypes`, we can have representation-polymorphic+ newtypes:++ type UN :: TYPE rep -> TYPE rep+ newtype UN a = MkUN a++ `tcHasFixedRuntimeRep UN = False`++ For example, `UN @Int8Rep Int8#` is represented by an 8-bit value,+ while `UN @LiftedRep Int` is represented by a heap pointer.++ To distinguish whether we are dealing with a representation-polymorphic newtype,+ we keep track of which situation we are in using the 'nt_fixed_rep'+ field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field+ to compute 'tcHasFixedRuntimeRep'.++ - A similar story can be told for datatypes: we're usually OK,+ except with `-XUnliftedDatatypes` which allows for levity polymorphism,+ e.g.:++ type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l)+ type UC a = MkUC a++ `tcHasFixedRuntimeRep UC = False`++ Here, we keep track of whether we are dealing with a levity-polymorphic+ unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon'+ constructor of 'AlgTyConRhs'.++ N.B.: technically, the representation of a datatype is fixed,+ as it is always a pointer. However, we currently require that we+ know the specific `RuntimeRep`: knowing that it's `BoxedRep l`+ for a type-variable `l` isn't enough. See #15532. -} -- | Represents right-hand-sides of 'TyCon's for algebraic types@@ -1039,8 +1122,21 @@ -- tag (see the tag assignment in mkTyConTagMap) data_cons_size :: Int, -- ^ Cached value: length data_cons- is_enum :: Bool -- ^ Cached value: is this an enumeration type?+ is_enum :: Bool, -- ^ Cached value: is this an enumeration type? -- See Note [Enumeration types]+ data_fixed_lev :: Bool+ -- ^ 'True' if the data type constructor has+ -- a known, fixed levity when fully applied+ -- to its arguments, False otherwise.+ --+ -- This can only be 'False' with UnliftedDatatypes,+ -- e.g.+ --+ -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A }+ --+ -- This boolean is cached to make it cheaper to check+ -- for levity and representation-polymorphism in+ -- tcHasFixedRuntimeRep. } | TupleTyCon { -- A boxed, unboxed, or constraint tuple@@ -1084,29 +1180,37 @@ -- See Note [Newtype eta] -- Watch out! If any newtypes become transparent -- again check #1072.- nt_lev_poly :: Bool- -- 'True' if the newtype can be- -- representation-polymorphic when fully applied to its- -- arguments, 'False' otherwise.- -- This can only ever be 'True' with UnliftedNewtypes.+ nt_fixed_rep :: Bool+ -- ^ 'True' if the newtype has a know, fixed representation+ -- when fully applied to its arguments, 'False' otherwise.+ -- This can only ever be 'False' with UnliftedNewtypes. --- -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt)+ -- Example: --- -- This is cached to make it cheaper to check if a- -- variable binding is representation-polymorphic,- -- as used by isTcLevPoly.+ -- > newtype N (a :: TYPE r) = MkN a+ --+ -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt)+ --+ -- This boolean is cached to make it cheaper to check if a+ -- variable binding is representation-polymorphic+ -- in tcHasFixedRuntimeRep. } mkSumTyConRhs :: [DataCon] -> AlgTyConRhs mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs-mkDataTyConRhs cons+-- | Create an 'AlgTyConRhs' from the data constructors,+-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`).+mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity+ -> [DataCon]+ -> AlgTyConRhs+mkLevPolyDataTyConRhs fixed_lev cons = DataTyCon { data_cons = cons, data_cons_size = length cons,- is_enum = not (null cons) && all is_enum_con cons+ is_enum = not (null cons) && all is_enum_con cons, -- See Note [Enumeration types] in GHC.Core.TyCon+ data_fixed_lev = fixed_lev } where is_enum_con con@@ -1114,6 +1218,12 @@ <- dataConFullSig con = null ex_tvs && null eq_spec && null theta && null arg_tys +-- | Create an 'AlgTyConRhs' from the data constructors.+--+-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic.+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs = mkLevPolyDataTyConRhs False+ -- | Some promoted datacons signify extra info relevant to GHC. For example, -- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' -- constructor of 'PrimRep'. This data structure allows us to store this@@ -1388,8 +1498,8 @@ tyConRepName_maybe :: TyCon -> Maybe TyConRepName tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) = Just rep_nm-tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm })- = mb_rep_nm+tyConRepName_maybe (PrimTyCon { primRepName = rep_nm })+ = Just rep_nm tyConRepName_maybe (AlgTyCon { algTcParent = parent }) | VanillaAlgTyCon rep_nm <- parent = Just rep_nm | ClassTyCon _ rep_nm <- parent = Just rep_nm@@ -1861,10 +1971,11 @@ -- | Create an unlifted primitive 'TyCon', such as @Int#@. mkPrimTyCon :: Name -> [TyConBinder]- -> Kind -- ^ /result/ kind, never representation-polymorphic+ -> Kind -- ^ /result/ kind+ -- Must answer 'True' to 'isFixedRuntimeRepKind' (no representation polymorphism). -> [Role] -> TyCon mkPrimTyCon name binders res_kind roles- = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)+ = mkPrimTyCon' name binders res_kind roles True (mkPrelTyConRepName name) -- | Kind constructors mkKindTyCon :: Name -> [TyConBinder]@@ -1873,22 +1984,23 @@ mkKindTyCon name binders res_kind roles rep_nm = tc where- tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)+ tc = mkPrimTyCon' name binders res_kind roles False rep_nm -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> TyCon mkLiftedPrimTyCon name binders res_kind roles- = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)+ = mkPrimTyCon' name binders res_kind roles False rep_nm where rep_nm = mkPrelTyConRepName name mkPrimTyCon' :: Name -> [TyConBinder]- -> Kind -- ^ /result/ kind, never representation-polymorphic+ -> Kind -- ^ /result/ kind+ -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). -- (If you need a representation-polymorphic PrimTyCon,- -- change isTcLevPoly.)+ -- change tcHasFixedRuntimeRep.) -> [Role]- -> Bool -> Maybe TyConRepName -> TyCon+ -> Bool -> TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm = let tc = PrimTyCon {@@ -1980,7 +2092,7 @@ -- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) isAbstractTyCon :: TyCon -> Bool-isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True+isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True isAbstractTyCon _ = False -- | Does this 'TyCon' represent something that cannot be defined in Haskell?@@ -2359,26 +2471,62 @@ in tc' setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) --- | Could this TyCon ever be representation-polymorphic when fully applied?--- True is safe. False means we're sure. Does only a quick check--- based on the TyCon's category.--- Precondition: The fully-applied TyCon has kind (TYPE blah)-isTcLevPoly :: TyCon -> Bool-isTcLevPoly FunTyCon{} = False-isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs })+-- | Does this 'TyCon' have a fixed RuntimeRep when fully applied,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?+--+-- False is safe. True means we're sure.+-- Does only a quick check, based on the TyCon's category.+--+-- See Note [Representation-polymorphic TyCons]+tcHasFixedRuntimeRep :: TyCon -> Bool+tcHasFixedRuntimeRep FunTyCon{} = True+tcHasFixedRuntimeRep (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) | UnboxedAlgTyCon _ <- parent- = True- | NewTyCon { nt_lev_poly = lev_poly } <- rhs- = lev_poly -- Newtypes can be representation-polymorphic- -- with UnliftedNewtypes (#17360)- | otherwise = False-isTcLevPoly SynonymTyCon{} = True-isTcLevPoly FamilyTyCon{} = True-isTcLevPoly PrimTyCon{} = False-isTcLevPoly TcTyCon{} = False-isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc)+ | NewTyCon { nt_fixed_rep = fixed_rep } <- rhs+ = fixed_rep -- A newtype might not have a fixed runtime representation+ -- with UnliftedNewtypes (#17360)+ | DataTyCon { data_fixed_lev = fixed_lev } <- rhs+ = fixed_lev -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).+ -- NB: the current representation-polymorphism checks require that+ -- the representation be fully-known, including levity variables.+ -- This might be relaxed in the future (#15532).+ | AbstractTyCon {} <- rhs+ = False -- An abstract TyCon might not have a fixed runtime representation.+ -- Note that this is an entirely different matter from the concreteness+ -- of the 'TyCon', in the sense of 'isConcreteTyCon'.+ | otherwise+ = True+tcHasFixedRuntimeRep SynonymTyCon{} = False+tcHasFixedRuntimeRep FamilyTyCon{} = False+tcHasFixedRuntimeRep PrimTyCon{} = True+tcHasFixedRuntimeRep TcTyCon{} = False+tcHasFixedRuntimeRep tc@PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) +-- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?+--+-- Used for representation polymorphism checks.+isConcreteTyCon :: TyCon -> Bool+isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour++-- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)?+--+-- Used for representation polymorphism checks.+isConcreteTyConFlavour :: TyConFlavour -> Bool+isConcreteTyConFlavour = \case+ ClassFlavour -> True+ TupleFlavour {} -> True+ SumFlavour -> True+ DataTypeFlavour -> True+ NewtypeFlavour -> True+ AbstractTypeFlavour -> True -- See (3) in Note [Solving Concrete# constraints] in GHC.Tc.Utils.Concrete+ DataFamilyFlavour {} -> False -- See+ OpenTypeFamilyFlavour {} -> False+ ClosedTypeFamilyFlavour -> False+ TypeSynonymFlavour -> False+ BuiltInTypeFlavour -> True+ PromotedDataConFlavour -> True+ {- ----------------------------------------------- -- Expand type-constructor applications@@ -2757,7 +2905,7 @@ tcFlavourMustBeSaturated DataFamilyFlavour{} = False tcFlavourMustBeSaturated TupleFlavour{} = False tcFlavourMustBeSaturated SumFlavour = False-tcFlavourMustBeSaturated AbstractTypeFlavour = False+tcFlavourMustBeSaturated AbstractTypeFlavour {} = False tcFlavourMustBeSaturated BuiltInTypeFlavour = False tcFlavourMustBeSaturated PromotedDataConFlavour = False tcFlavourMustBeSaturated TypeSynonymFlavour = True@@ -2774,7 +2922,7 @@ tcFlavourIsOpen NewtypeFlavour = False tcFlavourIsOpen TupleFlavour{} = False tcFlavourIsOpen SumFlavour = False-tcFlavourIsOpen AbstractTypeFlavour = False+tcFlavourIsOpen AbstractTypeFlavour {} = False tcFlavourIsOpen BuiltInTypeFlavour = False tcFlavourIsOpen PromotedDataConFlavour = False tcFlavourIsOpen TypeSynonymFlavour = False
compiler/GHC/Core/Type.hs view
@@ -145,7 +145,7 @@ Kind, -- ** Finding the kind of a type- typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,+ typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep, tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, tcIsBoxedTypeKind, tcIsRuntimeTypeKind, @@ -233,7 +233,7 @@ -- * Kinds isConstraintKindCon, classifiesTypeWithValues,- isKindLevPoly+ isConcrete, isFixedRuntimeRepKind, ) where import GHC.Prelude@@ -388,6 +388,31 @@ See also "A Role for Dependent Types in Haskell", ICFP 2019, which describes how roles in kinds might work out. +One annoying consequence of this inconsistency is that we can get ill-kinded+updates to metavariables. #20356 is a case in point. Simplifying somewhat,+we end up with+ [W] (alpha :: Constraint) ~ (Int :: Type)+This is heterogeneous, so we produce+ [W] co :: (Constraint ~ Type)+and transform our original wanted to become+ [W] alpha ~ Int |> sym co+in accordance with Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical.+Our transformed wanted is now homogeneous (both sides have kind Constraint)+and so we unify alpha := Int |> sym co.++However, it's not so easy: when we build the cast (Int |> sym co), we actually+just get Int back. This is because we forbid reflexive casts (invariant (EQ2) of+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep), and co looks+reflexive: it relates Type and Constraint, even though these are considered+identical in Core. Above, when we tried to say alpha := Int |> sym co, we+really ended up doing alpha := Int -- even though alpha :: Constraint and+Int :: Type have different kinds. Nothing has really gone wrong, though:+we still emitted [W] co :: (Constraint ~ Type), which will be insoluble+and lead to a decent error message. We simply need not to fall over at the+moment of unification, because all will be OK in the end. We thus use the+Core eqType, not the Haskell tcEqType, in the kind check for a meta-tyvar+unification in GHC.Tc.Utils.TcMType.writeMetaTyVarRef.+ -} -- | Gives the typechecker view of a type. This unwraps synonyms but@@ -2946,31 +2971,32 @@ typeLiteralKind (StrTyLit {}) = typeSymbolKind typeLiteralKind (CharTyLit {}) = charTy --- | Returns True if a type is representation-polymorphic. Should be the same--- as (isKindLevPoly . typeKind) but much faster.--- Precondition: The type has kind (TYPE blah)-isTypeLevPoly :: Type -> Bool-isTypeLevPoly = go+-- | Returns True if a type has a fixed runtime rep,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+--+-- This function is equivalent to @('isFixedRuntimeRepKind' . 'typeKind')@,+-- but much faster.+--+-- __Precondition:__ The type has kind @('TYPE' blah)@+typeHasFixedRuntimeRep :: Type -> Bool+typeHasFixedRuntimeRep = go where- go ty@(TyVarTy {}) = check_kind ty- go ty@(AppTy {}) = check_kind ty- go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False- | otherwise = check_kind ty- go (ForAllTy _ ty) = go ty- go (FunTy {}) = False- go (LitTy {}) = False- go ty@(CastTy {}) = check_kind ty- go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty)-- check_kind = isKindLevPoly . typeKind---- | Looking past all pi-types, is the end result potentially--- representation-polymorphic?--- Example: True for (forall r (a :: TYPE r). String -> a)--- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)-resultIsLevPoly :: Type -> Bool-resultIsLevPoly = isTypeLevPoly . snd . splitPiTys+ go (TyConApp tc _)+ | tcHasFixedRuntimeRep tc = True+ go (FunTy {}) = True+ go (LitTy {}) = True+ go (ForAllTy _ ty) = go ty+ go ty = isFixedRuntimeRepKind (typeKind ty) +-- | Looking past all pi-types, does the end result have a+-- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?+--+-- Examples:+--+-- * False for @(forall r (a :: TYPE r). String -> a)@+-- * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@+resultHasFixedRuntimeRep :: Type -> Bool+resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys {- ********************************************************************** * *@@ -3309,26 +3335,37 @@ during type inference. -} --- | Tests whether the given kind (which should look like @TYPE x@)--- is something other than a constructor tree (that is, constructors at every node).--- E.g. True of TYPE k, TYPE (F Int)--- False of TYPE 'LiftedRep-isKindLevPoly :: Kind -> Bool-isKindLevPoly k = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $- -- the isLiftedTypeKind check is necessary b/c of Constraint- go k+-- | Tests whether the given kind is a constructor tree+-- (that is, constructors at every node).+--+-- E.g. @False@ for @TYPE k@, @TYPE (F Int)@+-- @True@ for @TYPE 'LiftedRep@+--+-- __Precondition:__ The type has kind @('TYPE' blah)@.+isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool+isFixedRuntimeRepKind k+ = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $+ -- the isLiftedTypeKind check is necessary b/c of Constraint+ isConcrete k where- go ty | Just ty' <- coreView ty = go ty'- go TyVarTy{} = True- go AppTy{} = True -- it can't be a TyConApp- go (TyConApp tc tys) = isFamilyTyCon tc || any go tys- go ForAllTy{} = True- go (FunTy _ w t1 t2) = go w || go t1 || go t2- go LitTy{} = False- go CastTy{} = True- go CoercionTy{} = True- _is_type = classifiesTypeWithValues k++-- | Tests whether the given type is a constructor tree,+-- consisting only of concrete type constructors and applications.+isConcrete :: Type -> Bool+isConcrete = go+ where+ go ty | Just ty' <- coreView ty = go ty'+ go TyVarTy{} = False+ go AppTy{} = False -- it can't be a TyConApp+ go (TyConApp tc tys)+ | isConcreteTyCon tc = all go tys+ | otherwise = False+ go ForAllTy{} = False+ go (FunTy _ w t1 t2) = go w && go t1 && go t2+ go LitTy{} = True+ go CastTy{} = False+ go CoercionTy{} = False ----------------------------------------- -- | Does this classify a type allowed to have values? Responds True to things
compiler/GHC/Core/Type.hs-boot view
@@ -19,6 +19,7 @@ coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool+isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool tYPE :: Type -> Type
compiler/GHC/Core/Unfold.hs view
@@ -18,8 +18,6 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Core.Unfold ( Unfolding, UnfoldingGuidance, -- Abstract types @@ -32,7 +30,7 @@ ArgSummary(..), couldBeSmallEnoughToInline, inlineBoringOk,- certainlyWillInline, smallEnoughToInline,+ smallEnoughToInline, callSiteInline, CallCtxt(..), calcUnfoldingGuidance@@ -45,12 +43,11 @@ import GHC.Core import GHC.Core.Utils import GHC.Types.Id-import GHC.Types.Demand ( isDeadEndSig ) import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info-import GHC.Types.Basic ( Arity, isNoInlinePragma )+import GHC.Types.Basic ( Arity ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )@@ -961,89 +958,7 @@ smallEnoughToInline _ _ = False -------------------certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding--- ^ 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 fn_unf of- CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src }- | 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' = -- Do not change InlineCompulsory!- case src of- InlineCompulsory -> InlineCompulsory- _ -> InlineStable-- DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense- -- to do so, and even if it is currently a- -- loop breaker, it may not be later-- _other_unf -> Nothing-- where- noinline = isNoInlinePragma (inlinePragInfo fn_info)- fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline-- -- 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 size args src'- | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks]- , not (isDeadEndSig (dmdSigInfo fn_info))- -- Do not unconditionally inline a bottoming functions even if- -- it seems smallish. We've carefully lifted it out to top level,- -- 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 = src'- , uf_guidance = UnfWhen { ug_arity = unf_arity- , ug_unsat_ok = unSaturatedOk- , ug_boring_ok = inlineBoringOk expr } })- -- Note the "unsaturatedOk". A function like f = \ab. a- -- will certainly inline, even if partially applied (f e), so we'd- -- better make sure that the transformed inlining has the same property- | otherwise- = Nothing--{- Note [certainlyWillInline: be careful of thunks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Don't claim that thunks will certainly inline, because that risks work-duplication. Even if the work duplication is not great (eg is_cheap-holds), it can make a big difference in an inner loop In #5623 we-found that the WorkWrap phase thought that- y = case x of F# v -> F# (v +# v)-was certainlyWillInline, so the addition got duplicated.--Note that we check arityInfo instead of the arity of the unfolding to detect-this case. This is so that we don't accidentally fail to inline small partial-applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2-(say). Here there is no risk of work duplication, and the RHS is tiny, so-certainlyWillInline should return True. But `unf_arity` is zero! However f's-arity, gotten from `arityInfo fn_info`, is 1.--Failing to say that `f` will inline forces W/W to generate a potentially huge-worker for f that will immediately cancel with `g`'s wrapper anyway, causing-unnecessary churn in the Simplifier while arriving at the same result.--Note [certainlyWillInline: INLINABLE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-certainlyWillInline /must/ return Nothing for a large INLINABLE thing,-even though we have a stable inlining, so that strictness w/w takes-place. It makes a big difference to efficiency, and the w/w pass knows-how to transfer the INLINABLE info to the worker; see WorkWrap-Note [Worker/wrapper for INLINABLE functions]-+{- ************************************************************************ * * \subsection{callSiteInline}
compiler/GHC/Core/Unfold/Make.hs view
@@ -1,4 +1,4 @@-+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Unfolding creation module GHC.Core.Unfold.Make@@ -16,6 +16,7 @@ , mkCompulsoryUnfolding' , mkDFunUnfolding , specUnfolding+ , certainlyWillInline ) where @@ -28,6 +29,7 @@ import GHC.Core.Utils import GHC.Types.Basic import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Demand ( DmdSig, isDeadEndSig ) import GHC.Utils.Outputable@@ -309,4 +311,92 @@ uf_expandable = exprIsExpandable expr, uf_guidance = guidance } +----------------+certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding+-- ^ Sees if the unfolding is pretty certain to inline.+-- If so, return a *stable* unfolding for it, that will always inline.+-- The CoreExpr is the WW'd and simplified RHS. In contrast, the unfolding+-- template might not have been WW'd yet.+certainlyWillInline opts fn_info rhs'+ = case fn_unf of+ CoreUnfolding { uf_guidance = guidance, uf_src = src }+ | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions]+ | otherwise+ -> case guidance of+ UnfNever -> Nothing+ UnfWhen {} -> Just (fn_unf { uf_src = src', uf_tmpl = tmpl' })+ -- INLINE functions have UnfWhen+ UnfIfGoodArgs { ug_size = size, ug_args = args }+ -> do_cunf size args src' tmpl'+ where+ src' = -- Do not change InlineCompulsory!+ case src of+ InlineCompulsory -> InlineCompulsory+ _ -> InlineStable+ tmpl' = -- Do not overwrite stable unfoldings!+ case src of+ InlineRhs -> occurAnalyseExpr rhs'+ _ -> uf_tmpl fn_unf + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense+ -- to do so, and even if it is currently a+ -- loop breaker, it may not be later++ _other_unf -> Nothing++ where+ noinline = isNoInlinePragma (inlinePragInfo fn_info)+ fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline++ -- 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 size args src' tmpl'+ | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks]+ , not (isDeadEndSig (dmdSigInfo fn_info))+ -- Do not unconditionally inline a bottoming functions even if+ -- it seems smallish. We've carefully lifted it out to top level,+ -- 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 = src'+ , uf_tmpl = tmpl'+ , uf_guidance = UnfWhen { ug_arity = unf_arity+ , ug_unsat_ok = unSaturatedOk+ , ug_boring_ok = inlineBoringOk tmpl' } })+ -- Note the "unsaturatedOk". A function like f = \ab. a+ -- will certainly inline, even if partially applied (f e), so we'd+ -- better make sure that the transformed inlining has the same property+ | otherwise+ = Nothing++{- Note [certainlyWillInline: be careful of thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't claim that thunks will certainly inline, because that risks work+duplication. Even if the work duplication is not great (eg is_cheap+holds), it can make a big difference in an inner loop In #5623 we+found that the WorkWrap phase thought that+ y = case x of F# v -> F# (v +# v)+was certainlyWillInline, so the addition got duplicated.++Note that we check arityInfo instead of the arity of the unfolding to detect+this case. This is so that we don't accidentally fail to inline small partial+applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2+(say). Here there is no risk of work duplication, and the RHS is tiny, so+certainlyWillInline should return True. But `unf_arity` is zero! However f's+arity, gotten from `arityInfo fn_info`, is 1.++Failing to say that `f` will inline forces W/W to generate a potentially huge+worker for f that will immediately cancel with `g`'s wrapper anyway, causing+unnecessary churn in the Simplifier while arriving at the same result.++Note [certainlyWillInline: INLINABLE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+certainlyWillInline /must/ return Nothing for a large INLINABLE thing,+even though we have a stable inlining, so that strictness w/w takes+place. It makes a big difference to efficiency, and the w/w pass knows+how to transfer the INLINABLE info to the worker; see WorkWrap+Note [Worker/wrapper for INLINABLE functions]+-}
compiler/GHC/Core/Unify.hs view
@@ -47,6 +47,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot ) import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -1236,8 +1237,17 @@ -- this is because the range of the subst is the target -- type, not the template type. So, just check for -- normal type equality.- unless ((ty' `mkCastTy` kco) `eqType` ty) $- surelyApart+ unless ((ty' `mkCastTy` kco) `tcEqType` ty) $+ surelyApart+ -- NB: it's important to use `tcEqType` instead of `eqType` here,+ -- otherwise we might not reject a substitution+ -- which unifies `Type` with `Constraint`, e.g.+ -- a call to tc_unify_tys with arguments+ --+ -- tys1 = [k,k]+ -- tys2 = [Type, Constraint]+ --+ -- See test cases: T11715b, T20521. Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue uUnrefined :: UMEnv@@ -1549,6 +1559,8 @@ | tyCoVarsOfType ty `isNotInDomainOf` subst , Just (ty', _) <- isReflCo_maybe co , ty `eqType` ty'+ -- Why `eqType` and not `tcEqType`? Because this function is only used+ -- during coercion optimisation, after type-checking has finished. = Just subst where
compiler/GHC/Core/Utils.hs view
@@ -23,7 +23,6 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType,- isExprLevPoly, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,@@ -191,46 +190,6 @@ mkLamTypes vs ty = foldr mkLamType ty vs --- | Is this expression representation-polymorphic? This should be the--- same as saying (isKindLevPoly . typeKind . exprType) but--- much faster.-isExprLevPoly :: CoreExpr -> Bool-isExprLevPoly = go- where- go (Var _) = False -- no representation-poly binders- go (Lit _) = False -- no representation-poly literals- go e@(App f _) | not (go_app f) = False- | otherwise = check_type e- go (Lam _ _) = False- go (Let _ e) = go e- go e@(Case {}) = check_type e -- checking type is fast- go e@(Cast {}) = check_type e- go (Tick _ e) = go e- go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e)- go (Coercion {}) = False -- this case can happen in GHC.Core.Opt.SetLevels-- check_type = isTypeLevPoly . exprType -- slow approach-- -- if the function is a variable (common case), check its- -- levityInfo. This might mean we don't need to look up and compute- -- on the type. Spec of these functions: return False if there is- -- no possibility, ever, of this expression becoming- -- representation-polymorphic, no matter what it's applied to;- -- return True otherwise.- -- Returning True is always safe. See also Note [Levity info] in- -- IdInfo- go_app (Var id) = not (isNeverLevPolyId id)- go_app (Lit _) = False- go_app (App f _) = go_app f- go_app (Lam _ e) = go_app e- go_app (Let _ e) = go_app e- go_app (Case _ _ ty _) = resultIsLevPoly ty- go_app (Cast _ co) = resultIsLevPoly (coercionRKind co)- go_app (Tick _ e) = go_app e- go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e)- go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)-- {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~@@ -2002,8 +1961,8 @@ -- see Note [Core top-level string literals] in "GHC.Core" exprIsTopLevelBindable expr ty = not (mightBeUnliftedType ty)- -- Note that 'expr' may be representation-polymorphic here, consequently- -- we must use 'mightBeUnliftedType' rather than 'isUnliftedType',+ -- Note that 'expr' may not have a fixed runtime representation here,+ -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType', -- as the latter would panic. || exprIsTickedString expr
compiler/GHC/CoreToIface.hs view
@@ -491,8 +491,8 @@ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) - ------------ Levity polymorphism ----------- levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity+ ------------ Representation polymorphism ----------+ levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity | otherwise = Nothing toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
compiler/GHC/Data/Bag.hs view
@@ -17,7 +17,7 @@ filterBag, partitionBag, partitionBagWith, concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,- listToBag, nonEmptyToBag, bagToList, mapAccumBagL,+ listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM,@@ -33,7 +33,7 @@ import GHC.Utils.Monad import Control.Monad import Data.Data-import Data.Maybe( mapMaybe )+import Data.Maybe( mapMaybe, listToMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable@@ -307,6 +307,12 @@ bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b++headMaybe :: Bag a -> Maybe a+headMaybe EmptyBag = Nothing+headMaybe (UnitBag v) = Just v+headMaybe (TwoBags b1 _) = headMaybe b1+headMaybe (ListBag l) = listToMaybe l instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag))
compiler/GHC/Data/FastString.hs view
@@ -155,10 +155,11 @@ -- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' bytesFS, fastStringToByteString :: FastString -> ByteString-bytesFS = fastStringToByteString+{-# INLINE[1] bytesFS #-}+bytesFS f = SBS.fromShort $ fs_sbs f {-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-}-fastStringToByteString f = SBS.fromShort $ fs_sbs f+fastStringToByteString = bytesFS fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs@@ -529,10 +530,17 @@ -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString+{-# NOINLINE[1] mkFastString #-} mkFastString str = inlinePerformIO $ do sbs <- utf8EncodeShortByteString str mkFastStringWith (mkNewFastStringShortByteString sbs) sbs++-- The following rule is used to avoid polluting the non-reclaimable FastString+-- table with transient strings when we only want their encoding.+{-# RULES+"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeString x+#-} -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString
compiler/GHC/Data/List/SetOps.hs view
@@ -18,7 +18,7 @@ Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, -- Duplicate handling- hasNoDups, removeDups, findDupsEq,+ hasNoDups, removeDups, nubOrdBy, findDupsEq, equivClasses, -- Indexing@@ -160,6 +160,11 @@ where eq a b = case cmp a b of { EQ -> True; _ -> False } +-- | Remove the duplicates from a list using the provided+-- comparison function.+--+-- Returns the list without duplicates, and accumulates+-- all the duplicates in the second component of its result. removeDups :: (a -> a -> Ordering) -- Comparison function -> [a] -> ([a], -- List with no duplicates@@ -175,6 +180,11 @@ collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) collect_dups dups_so_far (x :| []) = (dups_so_far, x) collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)++-- | Remove the duplicates from a list using the provided+-- comparison function.+nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a]+nubOrdBy cmp xs = fst (removeDups cmp xs) findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] findDupsEq _ [] = []
compiler/GHC/Data/StringBuffer.hs view
@@ -47,8 +47,12 @@ -- * Parsing integers parseUnsignedInteger,- ) where + -- * Checking for bi-directional format characters+ containsBidirectionalFormatChar,+ bidirectionalFormatChars+ ) where+ import GHC.Prelude import GHC.Data.FastString@@ -213,6 +217,58 @@ (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in return (C# c#, StringBuffer buf len cur')+++bidirectionalFormatChars :: [(Char,String)]+bidirectionalFormatChars =+ [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)")+ , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)")+ , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)")+ , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)")+ , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)")+ , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)")+ , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)")+ , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)")+ , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)")+ ]++{-| Returns true if the buffer contains Unicode bi-directional formatting+characters.++https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types++Bidirectional format characters are one of+'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)"+'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)"+'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)"+'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)"+'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)"+'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)"+'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)"+'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)"+'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)"++This list is encoded in 'bidirectionalFormatChars'++-}+{-# INLINE containsBidirectionalFormatChar #-}+containsBidirectionalFormatChar :: StringBuffer -> Bool+containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#))+ = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do+ let go :: Int# -> Bool+ go i | isTrue# (i >=# len#) = False+ | otherwise = case utf8DecodeCharAddr# a# i of+ (# '\x202a'# , _ #) -> True+ (# '\x202b'# , _ #) -> True+ (# '\x202c'# , _ #) -> True+ (# '\x202d'# , _ #) -> True+ (# '\x202e'# , _ #) -> True+ (# '\x2066'# , _ #) -> True+ (# '\x2067'# , _ #) -> True+ (# '\x2068'# , _ #) -> True+ (# '\x2069'# , _ #) -> True+ (# _, bytes #) -> go (i +# bytes)+ pure $! go cur# -- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous -- to 'Data.List.head'). __Warning:__ The behavior is undefined if the
compiler/GHC/Driver/Backpack/Syntax.hs view
@@ -39,7 +39,7 @@ data HsComponentId = HsComponentId { hsPackageName :: PackageName,- hsComponentId :: IndefUnitId+ hsComponentId :: UnitId } instance Outputable HsComponentId where
− compiler/GHC/Driver/Config/Finder.hs
@@ -1,26 +0,0 @@-module GHC.Driver.Config.Finder (- FinderOpts(..),- initFinderOpts- ) where--import GHC.Prelude--import GHC.Driver.Session-import GHC.Unit.Finder---- | Create a new 'FinderOpts' from DynFlags.-initFinderOpts :: DynFlags -> FinderOpts-initFinderOpts flags = FinderOpts- { finder_importPaths = importPaths flags- , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)- , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)- , finder_ways = ways flags- , finder_enableSuggestions = gopt Opt_HelpfulErrors flags- , finder_hieDir = hieDir flags- , finder_hieSuf = hieSuf flags- , finder_hiDir = hiDir flags- , finder_hiSuf = hiSuf flags- , finder_objectDir = objectDir flags- , finder_objectSuf = objectSuf flags- , finder_stubDir = stubDir flags- }
compiler/GHC/Driver/Env/KnotVars.hs view
@@ -13,30 +13,41 @@ import GHC.Unit.Types ( Module ) import GHC.Unit.Module.Env import Data.Maybe+import GHC.Utils.Outputable -- See Note [Why is KnotVars not a ModuleEnv]+-- See Note [KnotVars invariants] data KnotVars a = KnotVars { kv_domain :: [Module] -- Domain of the function , Note [KnotVars: Why store the domain?] -- Invariant: kv_lookup is surjective relative to kv_domain , kv_lookup :: Module -> Maybe a -- Lookup function }+ | NoKnotVars deriving Functor +instance Outputable (KnotVars a) where+ ppr NoKnotVars = text "NoKnot"+ ppr (KnotVars dom _lookup) = text "Knotty:" <+> ppr dom+ emptyKnotVars :: KnotVars a-emptyKnotVars = KnotVars [] (const Nothing)+emptyKnotVars = NoKnotVars knotVarsFromModuleEnv :: ModuleEnv a -> KnotVars a+knotVarsFromModuleEnv me | isEmptyModuleEnv me = NoKnotVars knotVarsFromModuleEnv me = KnotVars (moduleEnvKeys me) (lookupModuleEnv me) knotVarElems :: KnotVars a -> [a] knotVarElems (KnotVars keys lookup) = mapMaybe lookup keys+knotVarElems NoKnotVars = [] lookupKnotVars :: KnotVars a -> Module -> Maybe a-lookupKnotVars (KnotVars _ lookup) = lookup+lookupKnotVars (KnotVars _ lookup) x = lookup x+lookupKnotVars NoKnotVars _ = Nothing knotVarsWithout :: Module -> KnotVars a -> KnotVars a knotVarsWithout this_mod (KnotVars loop_mods lkup) = KnotVars (filter (/= this_mod) loop_mods) (\that_mod -> if that_mod == this_mod then Nothing else lkup that_mod)+knotVarsWithout _ NoKnotVars = NoKnotVars {- Note [Why is KnotVars not a ModuleEnv]@@ -67,5 +78,27 @@ This could be refactored so that the lint functions knew about 'KnotVars' and delayed this check until deciding whether a variable was local or not. ++Note [KnotVars invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~++There is a simple invariant which should hold for the KnotVars constructor:++* At the end of upsweep, there should be no live KnotVars++This invariant is difficult to test but easy to check using ghc-debug. The usage of+NoKnotVars is intended to make this invariant easier to check.++The most common situation where a KnotVars is retained accidently is if a HscEnv+which contains reference to a KnotVars is used during interface file loading. The+thunks created during this process will retain a reference to the KnotVars. In theory,+all these references should be removed by 'typecheckLoop' as that retypechecks all+interface files in the loop without using KnotVars.++At the time of writing (MP: Oct 21) the invariant doesn't actually hold but also+doesn't seem to have too much of a negative consequence on compiler residency.+In theory it could be quite bad as each KnotVars may retain a stale reference to an entire TypeEnv.++See #20491 -}
compiler/GHC/Driver/Flags.hs view
@@ -536,7 +536,8 @@ | Opt_WarnMissingKindSignatures -- Since 9.2 | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2 | Opt_WarnRedundantStrictnessFlags -- Since 9.4- deriving (Eq, Show, Enum)+ | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2+ deriving (Eq, Ord, Show, Enum) -- | Return the names of a WarningFlag --@@ -635,6 +636,7 @@ Opt_WarnOperatorWhitespace -> "operator-whitespace" :| [] Opt_WarnImplicitLift -> "implicit-lift" :| [] Opt_WarnMissingExportedPatternSynonymSignatures -> "missing-exported-pattern-synonym-signatures" :| []+ Opt_WarnUnicodeBidirectionalFormatCharacters -> "unicode-bidirectional-format-characters" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options@@ -725,7 +727,8 @@ Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, Opt_WarnNonCanonicalMonoidInstances,- Opt_WarnOperatorWhitespaceExtConflict+ Opt_WarnOperatorWhitespaceExtConflict,+ Opt_WarnUnicodeBidirectionalFormatCharacters ] -- | Things you get with -W@@ -787,4 +790,3 @@ , Opt_WarnUnusedLocalBinds , Opt_WarnUnusedPatternBinds ]-
compiler/GHC/Driver/Pipeline/Monad.hs view
@@ -7,19 +7,13 @@ , PipeEnv(..) , PipelineOutput(..)- , getLocation ) where import GHC.Prelude import Control.Monad.IO.Class import qualified Data.Kind as K import GHC.Driver.Phases-import GHC.Driver.Config.Finder import GHC.Utils.TmpFs-import GHC.Driver.Session-import GHC.Types.SourceFile-import GHC.Unit.Module-import GHC.Unit.Finder -- The interface that the pipeline monad must implement. type TPipelineClass (f :: K.Type -> K.Type) (m :: K.Type -> K.Type)@@ -38,40 +32,6 @@ output_spec :: PipelineOutput -- ^ says where to put the pipeline output } --- | Calculate the ModLocation from the provided DynFlags-getLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation-getLocation pipe_env dflags src_flavour mod_name = do- let PipeEnv{ src_basename=basename,- src_suffix=suff } = pipe_env- location1 <- mkHomeModLocation2 fopts mod_name basename suff-- -- Boot-ify it if necessary- let location2- | HsBootFile <- src_flavour = addBootSuffixLocnOut location1- | otherwise = location1--- -- Take -ohi into account if present- -- This can't be done in mkHomeModuleLocation because- -- it only applies to the module being compiles- let ohi = outputHi dflags- location3 | Just fn <- ohi = location2{ ml_hi_file = fn }- | otherwise = location2-- -- Take -o into account if present- -- Very like -ohi, but we must *only* do this if we aren't linking- -- (If we're linking then the -o applies to the linked thing, not to- -- the object file for one module.)- -- Note the nasty duplication with the same computation in compileFile- -- above- let expl_o_file = outputFile dflags- location4 | Just ofile <- expl_o_file- , isNoLink (ghcLink dflags)- = location3 { ml_obj_file = ofile }- | otherwise = location3- return location4- where- fopts = initFinderOpts dflags data PipelineOutput = Temporary TempFileLifetime
compiler/GHC/Driver/Plugins.hs view
@@ -35,6 +35,10 @@ -- - access to loaded interface files with 'interfaceLoadAction' -- , keepRenamedSource+ -- ** Defaulting plugins+ -- | Defaulting plugins can add candidate types to the defaulting+ -- mechanism.+ , DefaultingPlugin -- ** Hole fit plugins -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions@@ -94,6 +98,9 @@ , tcPlugin :: TcPlugin -- ^ An optional typechecker plugin, which may modify the -- behaviour of the constraint solver.+ , defaultingPlugin :: DefaultingPlugin+ -- ^ An optional defaulting plugin, which may specify the+ -- additional type-defaulting rules. , holeFitPlugin :: HoleFitPlugin -- ^ An optional plugin to handle hole fits, which may re-order -- or change the list of valid hole fits and refinement hole fits.@@ -195,6 +202,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin+type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile@@ -213,6 +221,7 @@ defaultPlugin = Plugin { installCoreToDos = const return , tcPlugin = const Nothing+ , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return , pluginRecompile = impurePlugin
compiler/GHC/Driver/Session.hs view
@@ -38,11 +38,10 @@ xopt_DuplicateRecordFields, xopt_FieldSelectors, lang_set,- DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,- dynamicOutputFile, dynamicOutputHi,+ DynamicTooState(..), dynamicTooState, setDynamicNow, sccProfilingEnabled, DynFlags(..),- outputFile, hiSuf, objectSuf, ways,+ outputFile, objectSuf, ways, FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..),@@ -123,10 +122,7 @@ sExtraGccViaCFlags, sTargetPlatformString, sGhcWithInterpreter,- sGhcWithSMP,- sGhcRTSWays, sLibFFI,- sGhcRtsWithLibdw, GhcNameVersion(..), FileSettings(..), PlatformMisc(..),@@ -270,6 +266,7 @@ import Data.Char import Data.List (intercalate, sortBy) import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map import qualified Data.Set as Set import System.FilePath import System.Directory@@ -480,6 +477,9 @@ -- a pattern against. A safe guard -- against exponential blow-up. simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks+ dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an+ -- Unboxed demand on returned products with at most+ -- this number of fields specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types@@ -532,7 +532,6 @@ hiSuf_ :: String, hieSuf :: String, - dynamicTooFailed :: IORef Bool, dynObjectSuf_ :: String, dynHiSuf_ :: String, @@ -1022,33 +1021,21 @@ -- need Template-Haskell and GHC is dynamically linked (cf -- GHC.Driver.Pipeline.compileOne'). ----- This somewhat explains why we have "dynamicTooFailed :: IORef Bool" in--- DynFlags: when -dynamic-too is enabled, we try to build the dynamic objects,--- but we may fail and we shouldn't abort the whole compilation because the user--- may not even have asked for -dynamic-too in the first place. So instead we--- use this global variable to indicate that we can't build dynamic objects and--- compilation continues to build non-dynamic objects only. At the end of the--- non-dynamic pipeline, if this value indicates that the dynamic compilation--- failed, we run the whole pipeline again for the dynamic way (except on--- Windows...). See GHC.Driver.Pipeline.runPipeline.+-- We used to try and fall back from a dynamic-too failure but this feature+-- didn't work as expected (#20446) so it was removed to simplify the+-- implementation and not obscure latent bugs. data DynamicTooState = DT_Dont -- ^ Don't try to build dynamic objects too- | DT_Failed -- ^ Won't try to generate dynamic objects for some reason | DT_OK -- ^ Will still try to generate dynamic objects | DT_Dyn -- ^ Currently generating dynamic objects (in the backend) deriving (Eq,Show,Ord) -dynamicTooState :: MonadIO m => DynFlags -> m DynamicTooState+dynamicTooState :: DynFlags -> DynamicTooState dynamicTooState dflags- | not (gopt Opt_BuildDynamicToo dflags) = return DT_Dont- | otherwise = do- failed <- liftIO $ readIORef (dynamicTooFailed dflags)- if failed- then return DT_Failed- else if dynamicNow dflags- then return DT_Dyn- else return DT_OK+ | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont+ | dynamicNow dflags = DT_Dyn+ | otherwise = DT_OK setDynamicNow :: DynFlags -> DynFlags setDynamicNow dflags0 =@@ -1056,28 +1043,12 @@ { dynamicNow = True } -setDynamicTooFailed :: MonadIO m => DynFlags -> m ()-setDynamicTooFailed dflags =- liftIO $ writeIORef (dynamicTooFailed dflags) True---- | Compute the path of the dynamic object corresponding to an object file.-dynamicOutputFile :: DynFlags -> FilePath -> FilePath-dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags--dynamicOutputHi :: DynFlags -> FilePath -> FilePath-dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags- ----------------------------------------------------------------------------- -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do- let -- We can't build with dynamic-too on Windows, as labels before- -- the fork point are different depending on whether we are- -- building dynamically or not.- platformCanGenerateDynamicToo- = platformOS (targetPlatform dflags) /= OSMinGW32- refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo)+ let refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing refRtasmInfo <- newIORef Nothing@@ -1098,7 +1069,6 @@ (useColor dflags, colScheme dflags) tmp_dir <- normalise <$> getTemporaryDirectory return dflags{- dynamicTooFailed = refDynamicTooFailed, useUnicode = useUnicode', useColor = useColor', canUseColor = stderrSupportsAnsiColors,@@ -1132,6 +1102,7 @@ maxUncoveredPatterns = 4, maxPmCheckModels = 30, simplTickFactor = 100,+ dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple specConstrThreshold = Just 2000, specConstrCount = Just 3, specConstrRecursive = 3,@@ -1172,7 +1143,6 @@ hiSuf_ = "hi", hieSuf = "hie", - dynamicTooFailed = panic "defaultDynFlags: No dynamicTooFailed", dynObjectSuf_ = "dyn_" ++ phaseInputExt StopLn, dynHiSuf_ = "dyn_hi", dynamicNow = False,@@ -1874,26 +1844,19 @@ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ intercalate "/" (map wayDesc (Set.toAscList theWays)))) - let dflags3- | Just outFile <- outputFile_ dflags2 -- Only iff user specified -o ...- , not (isJust (dynOutputFile_ dflags2)) -- but not -dyno- = dflags2 { dynOutputFile_ = Just $ dynamicOutputFile dflags2 outFile }- | otherwise- = dflags2-- let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3+ let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2 -- Set timer stats & heap size- when (enableTimeStats dflags4) $ liftIO enableTimingStats- case (ghcHeapSize dflags4) of+ when (enableTimeStats dflags3) $ liftIO enableTimingStats+ case (ghcHeapSize dflags3) of Just x -> liftIO (setHeapSize x) _ -> return () - liftIO $ setUnsafeGlobalDynFlags dflags4+ liftIO $ setUnsafeGlobalDynFlags dflags3 let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) - return (dflags4, leftover, warns' ++ warns)+ return (dflags3, leftover, warns' ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode.@@ -2696,6 +2659,8 @@ ; return d }))) , make_ord_flag defFlag "fsimpl-tick-factor" (intSuffix (\n d -> d { simplTickFactor = n }))+ , make_ord_flag defFlag "fdmd-unbox-width"+ (intSuffix (\n d -> d { dmdUnboxWidth = n })) , make_ord_flag defFlag "fspec-constr-threshold" (intSuffix (\n d -> d { specConstrThreshold = Just n })) , make_ord_flag defFlag "fno-spec-constr-threshold"@@ -3124,10 +3089,11 @@ -- | Find the 'FlagSpec' for a 'WarningFlag'. flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)-flagSpecOf flag = listToMaybe $ filter check wWarningFlags- where- check fs = flagSpecFlag fs == flag+flagSpecOf = flip Map.lookup wWarningFlagMap +wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)+wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags+ -- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@ wWarningFlags :: [FlagSpec WarningFlag] wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)@@ -3241,7 +3207,8 @@ warnSpec Opt_WarnOperatorWhitespaceExtConflict, warnSpec Opt_WarnOperatorWhitespace, warnSpec Opt_WarnImplicitLift,- warnSpec Opt_WarnMissingExportedPatternSynonymSignatures+ warnSpec Opt_WarnMissingExportedPatternSynonymSignatures,+ warnSpec Opt_WarnUnicodeBidirectionalFormatCharacters ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@@@ -4610,6 +4577,12 @@ = let dflags' = gopt_unset dflags Opt_BuildDynamicToo warn = "-dynamic-too is not supported on Windows" in loop dflags' warn+ -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise+ -- you get two dynamic object files (.o and .dyn_o). (#20436)+ | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags+ = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+ warn = "-dynamic-too is ignored when using -dynamic"+ in loop dflags' warn -- Via-C backend only supports unregisterised ABI. Switch to a backend -- supporting it if possible.@@ -4868,11 +4841,6 @@ outputFile dflags | dynamicNow dflags = dynOutputFile_ dflags | otherwise = outputFile_ dflags--hiSuf :: DynFlags -> String-hiSuf dflags- | dynamicNow dflags = dynHiSuf_ dflags- | otherwise = hiSuf_ dflags objectSuf :: DynFlags -> String objectSuf dflags
compiler/GHC/Hs.hs view
@@ -74,7 +74,7 @@ hsmodLayout :: LayoutInfo, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.- hsmodName :: Maybe (Located ModuleName),+ hsmodName :: Maybe (LocatedA ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) hsmodExports :: Maybe (LocatedL [LIE GhcPs]),
compiler/GHC/Hs/Dump.hs view
@@ -139,7 +139,9 @@ epaAnchor :: EpaLocation -> SDoc epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r- epaAnchor (EpaDelta d) = parens $ text "EpaDelta" <+> deltaPos d+ epaAnchor (EpaDelta d cs) = case ba of+ NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs+ BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" deltaPos :: DeltaPos -> SDoc deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c
compiler/GHC/Hs/Expr.hs view
@@ -178,10 +178,6 @@ } -- | HsWrap appears only in typechecker output--- Invariant: The contained Expr is *NOT* itself an HsWrap.--- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr".--- This invariant is maintained by 'GHC.Hs.Utils.mkHsWrap'.--- hs_syn is something like HsExpr or HsCmd data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped @@ -1857,7 +1853,7 @@ ppr LambdaExpr = text "LambdaExpr" ppr CaseAlt = text "CaseAlt" ppr IfAlt = text "IfAlt"- ppr ProcExpr = text "ProcExpr"+ ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c ppr PatBindRhs = text "PatBindRhs" ppr PatBindGuards = text "PatBindGuards" ppr RecUpd = text "RecUpd"@@ -1866,6 +1862,11 @@ ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" +instance Outputable HsArrowMatchContext where+ ppr ProcExpr = text "ProcExpr"+ ppr ArrowCaseAlt = text "ArrowCaseAlt"+ ppr KappaExpr = text "KappaExpr"+ ----------------- instance OutputableBndrId p@@ -1882,15 +1883,20 @@ matchContextErrString PatBindGuards = text "pattern binding guards" matchContextErrString RecUpd = text "record update" matchContextErrString LambdaExpr = text "lambda"-matchContextErrString ProcExpr = text "proc"+matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"-matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"+matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour++matchArrowContextErrString :: HsArrowMatchContext -> SDoc+matchArrowContextErrString ProcExpr = text "proc"+matchArrowContextErrString ArrowCaseAlt = text "case"+matchArrowContextErrString KappaExpr = text "kappa" matchDoContextErrString :: HsDoFlavour -> SDoc matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
compiler/GHC/Hs/Extension.hs view
@@ -236,12 +236,12 @@ pprIfTc pp = case ghcPass @p of GhcTc -> pp _ -> empty -type instance Anno (HsToken tok) = EpAnnCO+type instance Anno (HsToken tok) = TokenLocation -noHsTok :: GenLocated (EpAnn a) (HsToken tok)-noHsTok = L noAnn HsTok+noHsTok :: GenLocated TokenLocation (HsToken tok)+noHsTok = L NoTokenLoc HsTok -type instance Anno (HsUniToken tok utok) = EpAnnCO+type instance Anno (HsUniToken tok utok) = TokenLocation -noHsUniTok :: GenLocated (EpAnn a) (HsUniToken tok utok)-noHsUniTok = L noAnn HsNormalTok+noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)+noHsUniTok = L NoTokenLoc HsNormalTok
compiler/GHC/Hs/ImpExp.hs view
@@ -20,7 +20,7 @@ import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc ( HsDocString )-import GHC.Types.SourceText ( SourceText(..), StringLiteral(..), pprWithSourceText )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable@@ -30,6 +30,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Name+import GHC.Types.PkgQual import Data.Data import Data.Maybe@@ -85,7 +86,7 @@ ideclSourceSrc :: SourceText, -- Note [Pragma source text] in GHC.Types.SourceText ideclName :: XRec pass ModuleName, -- ^ Module name.- ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier.+ ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.@@ -112,13 +113,18 @@ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation +type family ImportDeclPkgQual pass+type instance ImportDeclPkgQual GhcPs = RawPkgQual+type instance ImportDeclPkgQual GhcRn = PkgQual+type instance ImportDeclPkgQual GhcTc = PkgQual+ type instance XCImportDecl GhcPs = EpAnn EpAnnImportDecl type instance XCImportDecl GhcRn = NoExtField type instance XCImportDecl GhcTc = NoExtField type instance XXImportDecl (GhcPass _) = NoExtCon -type instance Anno ModuleName = SrcSpan+type instance Anno ModuleName = SrcSpanAnnA type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL -- ---------------------------------------------------------------------@@ -140,8 +146,8 @@ simpleImportDecl mn = ImportDecl { ideclExt = noAnn, ideclSourceSrc = NoSourceText,- ideclName = noLoc mn,- ideclPkgQual = Nothing,+ ideclName = noLocA mn,+ ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, ideclImplicit = False,@@ -151,7 +157,8 @@ } instance (OutputableBndrId p- , Outputable (Anno (IE (GhcPass p))))+ , Outputable (Anno (IE (GhcPass p)))+ , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg@@ -159,15 +166,11 @@ , ideclQualified = qual, ideclImplicit = implicit , ideclAs = as, ideclHiding = spec }) = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,- pp_qual qual False, pp_pkg pkg, ppr mod', pp_qual qual True, pp_as as])+ pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) 4 (pp_spec spec) where pp_implicit False = empty pp_implicit True = text "(implicit)"-- pp_pkg Nothing = empty- pp_pkg (Just (StringLiteral st p _))- = pprWithSourceText st (doubleQuotes (ftext p)) pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position.
compiler/GHC/Hs/Instances.hs view
@@ -366,6 +366,8 @@ deriving instance Data (HsStmtContext GhcRn) deriving instance Data (HsStmtContext GhcTc) +deriving instance Data HsArrowMatchContext+ deriving instance Data HsDoFlavour deriving instance Data (HsMatchContext GhcPs)
compiler/GHC/Hs/Utils.hs view
@@ -152,7 +152,6 @@ import Data.Function import Data.List ( partition, deleteBy ) import Data.Proxy-import Data.Data (Data) {- ************************************************************************@@ -786,13 +785,9 @@ mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) --- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@--- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr" mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc-mkHsWrap co_fn e | isIdHsWrapper co_fn = e-mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e-mkHsWrap co_fn (HsPar x lpar (L l e) rpar) = HsPar x lpar (L l (mkHsWrap co_fn e)) rpar-mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e)+mkHsWrap co_fn e | isIdHsWrapper co_fn = e+mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr GhcTc -> HsExpr GhcTc@@ -876,7 +871,7 @@ isInfixFunBind _ = False -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds-spanHsLocaLBinds :: (Data (HsLocalBinds (GhcPass p))) => HsLocalBinds (GhcPass p) -> SrcSpan+spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -5,14 +5,11 @@ import GHC.Builtin.Names (withDictName) import GHC.Core.Predicate (isEvVar)-import GHC.Core.TyCo.Ppr (pprWithTYPE) import GHC.Core.Type-import GHC.Core.Utils (exprType) import GHC.Driver.Flags import GHC.Hs import GHC.HsToCore.Errors.Types import GHC.Prelude-import GHC.Tc.Errors.Ppr (formatLevPolyErr, pprLevityPolyInType) import GHC.Types.Basic (pprRuleName) import GHC.Types.Error import GHC.Types.Id (idType)@@ -197,21 +194,6 @@ -> mkSimpleDecorated $ hang (text "Recursive bindings for unlifted types aren't allowed:") 2 (vcat (map ppr binds))- DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys- -> mkSimpleDecorated $- vcat [ hang (text "Cannot use function with representation-polymorphic arguments:")- 2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty))- , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat- [ text "(Note that representation-polymorphic primops,"- , text "such as 'coerce' and unboxed tuples, are eta-expanded"- , text "internally because they must occur fully saturated."- , text "Use -fprint-typechecker-elaboration to display the full expression.)"- ]- , hang (text "Representation-polymorphic arguments:")- 2 $ vcat $ map- (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))- bad_tys- ] DsRuleMightInlineFirst rule_name lhs_id _ -> mkSimpleDecorated $ vcat [ hang (text "Rule" <+> pprRuleName rule_name@@ -227,18 +209,7 @@ <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") ]- DsLevityPolyInExpr e prov- -> let extra = case prov of- LevityCheckHsExpr hsExpr -> ppr hsExpr- LevityCheckWpFun doc -> doc- LevityCheckInSyntaxExpr (DsArgNum n) expr- -> text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) - in mkSimpleDecorated $- formatLevPolyErr (exprType e) $$ (text "In the type of expression:" <+> extra)- DsLevityPolyInType ty prov- -> mkSimpleDecorated $ pprLevityPolyInType ty prov- diagnosticReason = \case DsUnknownMessage m -> diagnosticReason m DsEmptyEnumeration -> WarningWithFlag Opt_WarnEmptyEnumerations@@ -268,11 +239,8 @@ DsWrongDoBind{} -> WarningWithFlag Opt_WarnWrongDoBind DsUnusedDoBind{} -> WarningWithFlag Opt_WarnUnusedDoBind DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag- DsCannotUseFunWithPolyArgs{} -> ErrorWithoutFlag DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing- DsLevityPolyInExpr{} -> ErrorWithoutFlag- DsLevityPolyInType{} -> ErrorWithoutFlag diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m@@ -309,11 +277,8 @@ DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs] DsRecBindsNotAllowedForUnliftedTys{} -> noHints DsInvalidInstantiationDictAtType{} -> noHints- DsCannotUseFunWithPolyArgs{} -> noHints DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule]- DsLevityPolyInExpr{} -> noHints- DsLevityPolyInType{} -> noHints {- Note [Suggest NegativeLiterals]
compiler/GHC/HsToCore/Errors/Types.hs view
@@ -12,13 +12,11 @@ import GHC.Driver.Session import GHC.Hs import GHC.HsToCore.Pmc.Solver.Types-import GHC.Tc.Errors.Types (LevityCheckProvenance) import GHC.Types.Basic (Activation) import GHC.Types.Error import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.Name (Name)-import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt newtype MinBound = MinBound Integer@@ -144,30 +142,14 @@ | DsRecBindsNotAllowedForUnliftedTys ![LHsBindLR GhcTc GhcTc] - -- NOTE(adn) The first argument is an opaque 'expr' with an- -- 'Outputable' constraint because this messages is emitted from- -- 'GHC.HsToCore.Expr.checkLevPolyArgs' which gets passed a polymorphic- -- 'Outputable' type.- | forall expr. Outputable expr => DsCannotUseFunWithPolyArgs !expr !Type ![Type]- | DsRuleMightInlineFirst !RuleName !Var !Activation | DsAnotherRuleMightFireFirst !RuleName !RuleName -- the \"bad\" rule !Var - | DsLevityPolyInExpr !CoreExpr !LevityExprProvenance-- | DsLevityPolyInType !Type !LevityCheckProvenance- -- The positional number of the argument for an expression (first, second, third, etc) newtype DsArgNum = DsArgNum Int---- | Where the levity checking for the expression originated-data LevityExprProvenance- = LevityCheckHsExpr !(HsExpr GhcTc)- | LevityCheckWpFun !SDoc -- FIXME(adn) Alas 'WpFun' gives us an SDoc here.- | LevityCheckInSyntaxExpr !DsArgNum !(HsExpr GhcTc) -- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' -- constructor of a 'DsMessage'.
compiler/GHC/Iface/Syntax.hs view
@@ -230,7 +230,7 @@ -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom data IfaceConDecls- = IfAbstractTyCon -- c.f TyCon.AbstractTyCon+ = IfAbstractTyCon -- c.f TyCon.AbstractTyCon | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls @@ -375,7 +375,7 @@ -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection. Notably, none of the--- implicit ones are needed here, because they are not put it+-- implicit ones are needed here, because they are not put in -- interface files data IfaceIdDetails@@ -452,9 +452,9 @@ -} visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]-visibleIfConDecls IfAbstractTyCon = []-visibleIfConDecls (IfDataTyCon cs) = cs-visibleIfConDecls (IfNewTyCon c) = [c]+visibleIfConDecls (IfAbstractTyCon {}) = []+visibleIfConDecls (IfDataTyCon cs) = cs+visibleIfConDecls (IfNewTyCon c) = [c] ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names@@ -471,9 +471,9 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) = case cons of- IfAbstractTyCon -> []- IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd- IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds+ IfAbstractTyCon {} -> []+ IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd+ IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) = []
compiler/GHC/Iface/Type.hs view
@@ -73,8 +73,8 @@ ( coercibleTyCon, heqTyCon , tupleTyConName , manyDataConTyCon, oneDataConTyCon- , liftedRepTyCon )-import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy )+ , liftedRepTyCon, liftedDataConTyCon )+import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom@@ -1002,7 +1002,7 @@ Likewise, we default all Multiplicity variables to Many. This is done in a pass right before pretty-printing-(defaultNonStandardVars, controlled by+(defaultIfaceTyVarsOfKind, controlled by -fprint-explicit-runtime-reps and -XLinearTypes) This applies to /quantified/ variables like 'w' above. What about@@ -1028,7 +1028,8 @@ (test T18357a). Therefore, we additionally test for isTyConableTyVar. -} --- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity'+-- | Default 'RuntimeRep' variables to 'LiftedRep',+-- 'Levity' variables to 'Lifted', and 'Multiplicity' -- variables to 'Many'. For example: -- -- @@@ -1042,14 +1043,15 @@ -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ -- @ Just :: forall a . a -> Maybe a @ ----- We do this to prevent RuntimeRep and Multiplicity variables from+-- We do this to prevent RuntimeRep, Levity and Multiplicity variables from -- incurring a significant syntactic overhead in otherwise simple -- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] -- and #11549 for further discussion.-defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType-defaultNonStandardVars do_runtimereps do_multiplicities ty = go emptyFsEnv ty+defaultIfaceTyVarsOfKind :: DefaultVarsOfKind+ -> IfaceType -> IfaceType+defaultIfaceTyVarsOfKind def_ns_vars ty = go emptyFsEnv ty where- go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables+ go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables -> IfaceType -> IfaceType go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)@@ -1057,7 +1059,7 @@ -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind = let subs' = extendFsEnv subs var substituted_ty- -- Record that we should replace it with LiftedRep,+ -- Record that we should replace it with LiftedRep/Lifted/Many, -- and recurse, discarding the forall in go subs' ty @@ -1070,13 +1072,20 @@ go _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars- | do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+ | def_runtimeRep def_ns_vars+ , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) , isMetaTyVar tv , isTyConableTyVar tv = liftedRep_ty- | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+ | def_levity def_ns_vars+ , GHC.Core.Type.isLevityTy (tyVarKind tv) , isMetaTyVar tv , isTyConableTyVar tv+ = lifted_ty+ | def_multiplicity def_ns_vars+ , GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+ , isMetaTyVar tv+ , isTyConableTyVar tv = many_ty | otherwise = ty@@ -1112,8 +1121,15 @@ check_substitution :: IfaceType -> Maybe IfaceType check_substitution (IfaceTyConApp tc _)- | do_runtimereps, tc `ifaceTyConHasKey` runtimeRepTyConKey = Just liftedRep_ty- | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty+ | def_runtimeRep def_ns_vars+ , tc `ifaceTyConHasKey` runtimeRepTyConKey+ = Just liftedRep_ty+ | def_levity def_ns_vars+ , tc `ifaceTyConHasKey` levityTyConKey+ = Just lifted_ty+ | def_multiplicity def_ns_vars+ , tc `ifaceTyConHasKey` multiplicityTyConKey+ = Just many_ty check_substitution _ = Nothing -- | The type ('BoxedRep 'Lifted), also known as LiftedRep.@@ -1125,6 +1141,14 @@ liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon) where tc_name = getName liftedRepTyCon +-- | The type 'Lifted :: Levity'.+lifted_ty :: IfaceType+lifted_ty =+ IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))+ IA_Nil+ where dc_name = getName liftedDataConTyCon++-- | The type 'Many :: Multiplicity'. many_ty :: IfaceType many_ty = IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))@@ -1136,10 +1160,13 @@ = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> sdocOption sdocLinearTypes $ \linearTypes -> getPprStyle $ \sty ->- let do_runtimerep = not printExplicitRuntimeReps- do_multiplicity = not linearTypes+ let def_opts =+ DefaultVarsOfKind+ { def_runtimeRep = not printExplicitRuntimeReps+ , def_levity = not printExplicitRuntimeReps+ , def_multiplicity = not linearTypes } in if userStyle sty- then f (defaultNonStandardVars do_runtimerep do_multiplicity ty)+ then f (defaultIfaceTyVarsOfKind def_opts ty) else f ty instance Outputable IfaceAppArgs where
compiler/GHC/Linker/Types.hs view
@@ -101,10 +101,10 @@ -- | Information we can use to dynamically link modules into the compiler data Linkable = LM {- linkableTime :: UTCTime, -- ^ Time at which this linkable was built+ linkableTime :: !UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files)- linkableModule :: Module, -- ^ The linkable module itself+ linkableModule :: !Module, -- ^ The linkable module itself linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have yet to link. --
compiler/GHC/Parser/Annotation.hs view
@@ -14,6 +14,7 @@ -- * In-tree Exact Print Annotations AddEpAnn(..), EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,+ TokenLocation(..), DeltaPos(..), deltaPos, getDeltaLine, EpAnn(..), Anchor(..), AnchorOperation(..),@@ -99,7 +100,7 @@ {- Note [exact print annotations]-~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a parse tree of a Haskell module, how can we reconstruct the original Haskell source code, retaining all whitespace and source code comments? We need to track the locations of all@@ -393,18 +394,26 @@ -- The usual way an 'AddEpAnn' is created is using the 'mj' ("make -- jump") function, and then it can be inserted into the appropriate -- annotation.-data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Show,Eq,Ord)+data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) --- | The anchor for an @'AnnKeywordId'@. The Parser inserts the @'EpaSpan'@--- variant, giving the exact location of the original item in the--- parsed source. This can be replaced by the @'EpaDelta'@ version, to--- provide a position for the item relative to the end of the previous--- item in the source. This is useful when editing an AST prior to--- exact printing the changed one.-data EpaLocation = EpaSpan RealSrcSpan- | EpaDelta DeltaPos- deriving (Data,Show,Eq,Ord)+-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the+-- @'EpaSpan'@ variant, giving the exact location of the original item+-- in the parsed source. This can be replaced by the @'EpaDelta'@+-- version, to provide a position for the item relative to the end of+-- the previous item in the source. This is useful when editing an+-- AST prior to exact printing the changed one. The list of comments+-- in the @'EpaDelta'@ variant captures any comments between the prior+-- output and the thing being marked here, since we cannot otherwise+-- sort the relative order.+data EpaLocation = EpaSpan !RealSrcSpan+ | EpaDelta !DeltaPos ![LEpaComment]+ deriving (Data,Eq,Ord) +-- | Tokens embedded in the AST have an EpaLocation, unless they come from+-- generated code (e.g. by TH).+data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation+ deriving (Data,Eq,Ord)+ -- | Spacing between output items when exact printing. It captures -- the spacing from the current print position on the page to the -- position required for the thing about to be printed. This is@@ -438,7 +447,7 @@ -- partial function is safe. epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan epaLocationRealSrcSpan (EpaSpan r) = r-epaLocationRealSrcSpan (EpaDelta _) = panic "epaLocationRealSrcSpan"+epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l)@@ -446,11 +455,14 @@ instance Outputable EpaLocation where ppr (EpaSpan r) = text "EpaSpan" <+> ppr r- ppr (EpaDelta d) = text "EpaDelta" <+> ppr d+ ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs instance Outputable AddEpAnn where ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss +instance Ord AddEpAnn where+ compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2)+ -- --------------------------------------------------------------------- -- | The exact print annotations (EPAs) are kept in the HsSyn AST for@@ -487,11 +499,11 @@ -- new AST fragments out of old ones, and have them still printed out -- in a precise way. data EpAnn ann- = EpAnn { entry :: Anchor+ = EpAnn { entry :: !Anchor -- ^ Base location for the start of the syntactic element -- holding the annotations.- , anns :: ann -- ^ Annotations added by the Parser- , comments :: EpAnnComments+ , anns :: !ann -- ^ Annotations added by the Parser+ , comments :: !EpAnnComments -- ^ Comments enclosed in the SrcSpan of the element -- this `EpAnn` is attached to }@@ -558,7 +570,10 @@ -- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with -- an extra annotation type. This is mapped to a specific `GenLocated` -- usage in the AST through the `XRec` and `Anno` type families.-data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan }++-- Important that the fields are strict as these live inside L nodes which+-- are live for a long time.+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan } deriving (Data, Eq) -- See Note [XRec and Anno in the AST] @@ -625,7 +640,7 @@ = AddSemiAnn EpaLocation -- ^ Trailing ';' | AddCommaAnn EpaLocation -- ^ Trailing ',' | AddVbarAnn EpaLocation -- ^ Trailing '|'- deriving (Data,Show,Eq, Ord)+ deriving (Data, Eq, Ord) instance Outputable TrailingAnn where ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss@@ -793,7 +808,8 @@ addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n) , comments = comments n <> cs } where- addTrailing n = n { al_trailing = t : al_trailing n }+ -- See Note [list append in addTrailing*]+ addTrailing n = n { al_trailing = al_trailing n ++ [t]} -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation.@@ -804,7 +820,8 @@ addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n) , comments = comments n <> cs } where- addTrailing n = n { lann_trailing = t : lann_trailing n }+ -- See Note [list append in addTrailing*]+ addTrailing n = n { lann_trailing = lann_trailing n ++ [t] } -- | Helper function used in the parser to add a comma location to an -- existing annotation.@@ -813,9 +830,30 @@ = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l } where+ -- See Note [list append in addTrailing*] addTrailing :: NameAnn -> EpaLocation -> NameAnn- addTrailing n l = n { nann_trailing = AddCommaAnn l : nann_trailing n }+ addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]} +{-+Note [list append in addTrailing*]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN+functions are used to add a separator for an item when it occurs in a+list. So they are used to capture a comma, vbar, semicolon and similar.++In general, a given element will have zero or one of these. In+extreme (test) cases, there may be multiple semicolons.++In exact printing we sometimes convert the EpaLocation variant for an+trailing annotation to the EpaDelta variant, which cannot be sorted.++Hence it is critical that these annotations are captured in the order+they appear in the original source file.++And so we use the less efficient list append to preserve the order,+knowing that in most cases the original list is empty.+-}+ -- --------------------------------------------------------------------- -- |Helper function (temporary) during transition of names@@ -928,7 +966,7 @@ where go [] = [] go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest- go (AddEpAnn _ (EpaDelta _):rest) = go rest+ go (AddEpAnn _ (EpaDelta _ _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure -- this is the case.@@ -937,7 +975,7 @@ where go [] = [] go (AddEpAnn _ (EpaSpan s):rest) = s : go rest- go (AddEpAnn _ (EpaDelta _):rest) = go rest+ go (AddEpAnn _ (EpaDelta _ _):rest) = go rest widenAnchor :: Anchor -> [AddEpAnn] -> Anchor widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -28,6 +28,7 @@ import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) import qualified GHC.LanguageExtensions as LangExt+import Data.List.NonEmpty (NonEmpty((:|))) instance Diagnostic PsMessage where@@ -44,6 +45,20 @@ -> mkSimpleDecorated $ text "Multiple Haddock comments for a single entity are not allowed." $$ text "The extraneous comment will be ignored."+ PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs)+ -> mkSimpleDecorated $+ text "A unicode bidirectional formatting character" <+> parens (text desc)+ $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"+ $$ (case xs of+ [] -> empty+ xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs+ where+ pprChars [] = empty+ pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc+ $$ pprChars xs+ )+ $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"+ PsWarnTab tc -> mkSimpleDecorated $ text "Tab character found here"@@ -474,6 +489,7 @@ diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m+ PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters PsWarnTab{} -> WarningWithFlag Opt_WarnTabs PsWarnTransitionalLayout{} -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional PsWarnOperatorWhitespaceExtConflict{} -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict@@ -586,6 +602,7 @@ diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m PsHeaderMessage m -> psHeaderMessageHints m+ PsWarnBidirectionalFormatChars{} -> noHints PsWarnTab{} -> [SuggestUseSpaces] PsWarnTransitionalLayout{} -> noHints PsWarnOperatorWhitespaceExtConflict sym -> [SuggestUseWhitespaceAfter sym]
compiler/GHC/Parser/Errors/Types.hs view
@@ -16,6 +16,8 @@ import GHC.Types.Name.Reader import GHC.Unit.Module.Name import GHC.Utils.Outputable+import Data.List.NonEmpty (NonEmpty)+import GHC.Types.SrcLoc (PsLoc) -- The type aliases below are useful to make some type signatures a bit more -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.@@ -71,6 +73,14 @@ See Note [Messages from GHC.Parser.Header]. -} | PsHeaderMessage !PsHeaderMessage++ {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag)+ that occurs when unicode bi-directional format characters are found within in a file++ The 'PsLoc' contains the exact position in the buffer the character occured, and the+ string contains a description of the character.+ -}+ | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String)) {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs when tabulations (tabs) are found within a file.
compiler/GHC/Parser/Header.hs view
@@ -37,6 +37,7 @@ import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceText+import GHC.Types.PkgQual import GHC.Utils.Misc import GHC.Utils.Panic@@ -72,8 +73,8 @@ -- in the function result) -> IO (Either (Messages PsMessage)- ([(Maybe FastString, Located ModuleName)],- [(Maybe FastString, Located ModuleName)],+ ([(RawPkgQual, Located ModuleName)],+ [(RawPkgQual, Located ModuleName)], Bool, -- Is GHC.Prim imported or not Located ModuleName)) -- ^ The source imports and normal imports (with optional package@@ -96,7 +97,7 @@ imps = hsmodImports hsmod main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)- mod = mb_mod `orElse` L main_loc mAIN_NAME+ mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it.@@ -107,12 +108,12 @@ implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps- convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)+ convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i) in return (map convImport src_idecls , map convImport (implicit_imports ++ ordinary_imps) , not (null ghc_prim_import)- , mod)+ , reLoc mod) mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location@@ -136,8 +137,8 @@ unLoc (ideclName decl) == pRELUDE_NAME -- allow explicit "base" package qualifier (#19082, #17045) && case ideclPkgQual decl of- Nothing -> True- Just b -> sl_fs b == unitIdFS baseUnitId+ NoRawPkgQual -> True+ RawPkgQual b -> sl_fs b == unitIdFS baseUnitId loc' = noAnnSrcSpan loc@@ -145,8 +146,8 @@ preludeImportDecl = L loc' $ ImportDecl { ideclExt = noAnn, ideclSourceSrc = NoSourceText,- ideclName = L loc pRELUDE_NAME,- ideclPkgQual = Nothing,+ ideclName = L loc' pRELUDE_NAME,+ ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, -- Not a safe import ideclQualified = NotQualified,
compiler/GHC/Parser/PostProcess.hs view
@@ -74,6 +74,9 @@ UnpackednessPragma(..), mkMultTy, + -- Token location+ mkTokenLocation,+ -- Help with processing exports ImpExpSubSpec(..), ImpExpQcSpec(..),@@ -191,9 +194,9 @@ = do { let loc = noAnnSrcSpan loc' ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr- ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams+ ; tyvars <- checkTyVars (text "class") whereDots cls tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments- ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) (ann++annst) cs+ ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars@@ -217,9 +220,9 @@ ksig data_cons (L _ maybe_deriv) annsIn = do { let loc = noAnnSrcSpan loc' ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr- ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams+ ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments- ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) (ann ++ anns) cs+ ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdDExt = anns', tcdLName = tc, tcdTyVars = tyvars,@@ -251,9 +254,9 @@ mkTySynonym loc lhs rhs annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]- ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams+ ; tyvars <- checkTyVars (text "type") equalsDots tc tparams ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) (ann ++ anns) (cs1 Semi.<> cs2)+ ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) ; return (L (noAnnSrcSpan loc) (SynDecl { tcdSExt = anns' , tcdLName = tc, tcdTyVars = tyvars@@ -346,9 +349,9 @@ mkFamDecl loc info topLevel lhs ksig injAnn annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]- ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams+ ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) (ann++anns) (cs1 Semi.<> cs2)+ ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) ; return (L (noAnnSrcSpan loc) (FamDecl noExtField (FamilyDecl { fdExt = anns'@@ -453,7 +456,7 @@ add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs = EpAnn (Anchor rs UnchangedAnchor) (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs-add_where (AddEpAnn _ (EpaDelta _)) _ _ = panic "add_where"+add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where" -- EpaDelta should only be used for transformations valid_anchor :: RealSrcSpan -> Bool@@ -840,38 +843,45 @@ eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]- -> P ( LHsQTyVars GhcPs -- the synthesized type variables- , [AddEpAnn] ) -- action which adds annotations+ -> P (LHsQTyVars GhcPs) -- the synthesized type variables -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars pp_what equals_or_where tc tparms- = do { (tvs, anns) <- fmap unzip $ mapM check tparms- ; return (mkHsQTvs tvs, concat anns) }+ = do { tvs <- mapM check tparms+ ; return (mkHsQTvs tvs) } where check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))- check (HsValArg ty) = chkParens [] emptyComments ty+ check (HsValArg ty) = chkParens [] [] emptyComments ty check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens- chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs- -> P (LHsTyVarBndr () GhcPs, [AddEpAnn])- chkParens acc cs (L l (HsParTy an ty))- = chkParens (mkParensEpAnn (locA l) ++ acc) (cs Semi.<> epAnnComments an) ty- chkParens acc cs ty = do- tv <- chk acc cs ty- return (tv, reverse acc)+ chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs+ -> P (LHsTyVarBndr () GhcPs)+ chkParens ops cps cs (L l (HsParTy an ty))+ = let+ (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+ in+ chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty+ chkParens ops cps cs ty = chk ops cps cs ty -- Check that the name space is correct!- chk :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)- chk an cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))+ chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)+ chk ops cps cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) | isRdrTyVar tv- = return (L (widenLocatedAn (l Semi.<> annt) an)- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))- chk an cs (L l (HsTyVar ann _ (L ltv tv)))- | isRdrTyVar tv = return (L (widenLocatedAn l an)+ = let+ an = (reverse ops) ++ cps+ in+ return (L (widenLocatedAn (l Semi.<> annt) an)+ (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))+ chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))+ | isRdrTyVar tv+ = let+ an = (reverse ops) ++ cps+ in+ return (L (widenLocatedAn l an) (UserTyVar (addAnns ann an cs) () (L ltv tv)))- chk _ _ t@(L loc _)+ chk _ _ _ t@(L loc _) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) @@ -951,34 +961,36 @@ -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces checkTyClHdr is_cls ty- = goL ty [] [] Prefix+ = goL ty [] [] [] Prefix where- goL (L l ty) acc ann fix = go (locA l) ty acc ann fix+ goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix -- workaround to define '*' despite StarIsType- go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix+ go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix = do { addPsMessage (locA l) PsWarnStarBinder ; let name = mkOccName tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix- , ann') }+ , (reverse ops') ++ cps') } - go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix- | isRdrTc tc = return (ltc, acc, fix, ann)- go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix- | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)- go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensEpAnn l) fix- go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix- go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix- go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix+ go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix+ | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)+ go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix+ where+ (o,c) = mkParensEpAnn (realSrcSpan l)+ go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix+ go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix+ go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix = return (L (noAnnSrcSpan l) (nameRdrName tup_name)- , map HsValArg ts, fix, ann)+ , map HsValArg ts, fix, (reverse ops)++cps) where arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)- go l _ _ _ _+ go l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ (PsErrMalformedTyOrClDecl ty) @@ -1054,7 +1066,8 @@ EpAnnNotUsed -> ([],[],emptyComments) EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)- (AnnContext Nothing (op Semi.<> oparens) (cp Semi.<> cparens)) (cs Semi.<> cs')) l) ts)+ -- Append parens so that the original order in the source is maintained+ (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts) check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) -- to be sure HsParTy doesn't get into the way@@ -1311,26 +1324,29 @@ [LocatedA (PatBuilder GhcPs)],[AddEpAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS-isFunLhs e = go e [] []+isFunLhs e = go e [] [] [] where- go (L _ (PatBuilderVar (L loc f))) es ann- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))- go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann- go (L l (PatBuilderPar _ e _)) es@(_:_) ann- = go e es (ann ++ mkParensEpAnn (locA l))- go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ann+ go (L _ (PatBuilderVar (L loc f))) es ops cps+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))+ go (L _ (PatBuilderApp f e)) es ops cps = go f (e:es) ops cps+ go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps+ = let+ (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+ in+ go e es (o:ops) (c:cps)+ go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps | not (isRdrDataCon op) -- We have found the function!- = return (Just (L loc' op, Infix, (l:r:es), (anns ++ ann)))+ = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps))) | otherwise -- Infix data con; keep going- = do { mb_l <- go l es ann+ = do { mb_l <- go l es ops cps ; case mb_l of- Just (op', Infix, j : k : es', ann')- -> return (Just (op', Infix, j : op_app : es', ann'))+ Just (op', Infix, j : k : es', anns')+ -> return (Just (op', Infix, j : op_app : es', anns')) where op_app = L loc (PatBuilderOpApp k- (L loc' op) r (EpAnn loca anns cs))+ (L loc' op) r (EpAnn loca (reverse ops++cps) cs)) _ -> return Nothing }- go _ _ _ = return Nothing+ go _ _ _ _ = return Nothing mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs mkBangTy anns strictness =@@ -2994,12 +3010,27 @@ mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr -- See #18888 for the use of (SourceText "1") above- = HsLinearArrow (HsPct1 (L (getLoc pct Semi.<> locOf1) HsTok) arr)+ = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr) where- -- The location of "1" in "%1".- locOf1 :: EpAnn NoEpAnns- locOf1 = EpAnn (spanAsAnchor (locA (getLoc t))) NoEpAnns emptyComments+ -- The location of "%" combined with the location of "1".+ locOfPct1 :: TokenLocation+ locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t)) mkMultTy pct t arr = HsExplicitMult pct t arr++mkTokenLocation :: SrcSpan -> TokenLocation+mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc+mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)++-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.+token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation+token_location_widenR NoTokenLoc _ = NoTokenLoc+token_location_widenR tl (UnhelpfulSpan _) = tl+token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =+ (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))+token_location_widenR (TokenLoc (EpaDelta _ _)) _ =+ -- Never happens because the parser does not produce EpaDelta.+ panic "token_location_widenR: EpaDelta"+ ----------------------------------------------------------------------------- -- Token symbols
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -249,10 +249,10 @@ -- Only do this when the module header exists. headerDocs <- for @Maybe (hsmodName mod) $ \(L l_name _) ->- extendHdkA l_name $ liftHdkA $ do+ extendHdkA (locA l_name) $ liftHdkA $ do -- todo: register keyword location of 'module', see Note [Register keyword location] docs <-- inLocRange (locRangeTo (getBufPos (srcSpanStart l_name))) $+ inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $ takeHdkComments mkDocNext selectDocString docs
compiler/GHC/Platform.hs view
@@ -223,6 +223,7 @@ platformCConvNeedsExtension platform = case platformArch platform of ArchPPC_64 _ -> True ArchS390X -> True+ ArchRISCV64 -> True _ -> False @@ -253,10 +254,7 @@ { -- TODO Recalculate string from richer info? platformMisc_targetPlatformString :: String , platformMisc_ghcWithInterpreter :: Bool- , platformMisc_ghcWithSMP :: Bool- , platformMisc_ghcRTSWays :: String , platformMisc_libFFI :: Bool- , platformMisc_ghcRtsWithLibdw :: Bool , platformMisc_llvmTarget :: String }
compiler/GHC/Runtime/Context.hs view
@@ -6,7 +6,8 @@ , extendInteractiveContextWithIds , setInteractivePrintName , substInteractiveContext- , icExtendGblRdrEnv+ , replaceImportEnv+ , icReaderEnv , icInteractiveModule , icInScopeTTs , icPrintUnqual@@ -20,7 +21,7 @@ import GHC.Driver.Session import {-# SOURCE #-} GHC.Driver.Plugins -import GHC.Runtime.Eval.Types ( Resume )+import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) import GHC.Unit import GHC.Unit.Env@@ -182,6 +183,37 @@ Prelude> instance Eq T where ... -- This one overrides It's exactly the same for type-family instances. See #7102++Note [icReaderEnv recalculation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GlobalRdrEnv describing what’s in scope at the prompts consists+of all the imported things, followed by all the things defined on the prompt, with+shadowing. Defining new things on the prompt is easy: we shadow as needed and then extend the environment. But changing the set of imports, which can happen later as well,+is tricky: we need to re-apply the shadowing from all the things defined at the prompt!++For example:++ ghci> let empty = True+ ghci> import Data.IntMap.Strict -- Exports 'empty'+ ghci> empty -- Still gets the 'empty' defined at the prompt+ True+++It would be correct ot re-construct the env from scratch based on+`ic_tythings`, but that'd be quite expensive if there are many entires in+`ic_tythings` that shadow each other.++Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that+contians _just_ the things defined at the prompt, and use that in+`replaceImportEnv` to rebuild the full env. Conveniently, `shadowNames` takes+such an `OccEnv` to denote the set of names to shadow.++INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well+(else it would not be right to use pass `igre_prompt_env` to `shadowNames`.)++The definition of the IcGlobalRdrEnv type should conceptually be in this module, and+made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type.+- -} -- | Interactive context, recording information about the state of the@@ -200,7 +232,7 @@ -- See Note [The interactive package] ic_imports :: [InteractiveImport],- -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with+ -- ^ The GHCi top-level scope (icReaderEnv) is extended with -- these imports -- -- This field is only stored here so that the client@@ -213,11 +245,16 @@ -- definition (ie most recent at the front) -- See Note [ic_tythings] - ic_rn_gbl_env :: GlobalRdrEnv,- -- ^ The cached 'GlobalRdrEnv', built by- -- 'GHC.Runtime.Eval.setContext' and updated regularly- -- It contains everything in scope at the command line,- -- including everything in ic_tythings+ ic_gre_cache :: IcGlobalRdrEnv,+ -- ^ Essentially the cached 'GlobalRdrEnv'.+ --+ -- The GlobalRdrEnv contains everything in scope at the command+ -- line, both imported and everything in ic_tythings, with the+ -- correct shadowing.+ --+ -- The IcGlobalRdrEnv contains extra data to allow efficient+ -- recalculation when the set of imports change.+ -- See Note [icReaderEnv recalculation] ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during@@ -233,7 +270,7 @@ ic_default :: Maybe [Type], -- ^ The current default types, set by a 'default' declaration - ic_resume :: [Resume],+ ic_resume :: [Resume], -- ^ The stack of breakpoint contexts ic_monad :: Name,@@ -261,6 +298,11 @@ -- of this module, including the things imported -- into it. +emptyIcGlobalRdrEnv :: IcGlobalRdrEnv+emptyIcGlobalRdrEnv = IcGlobalRdrEnv+ { igre_env = emptyGlobalRdrEnv+ , igre_prompt_env = emptyGlobalRdrEnv+ } -- | Constructs an empty InteractiveContext. emptyInteractiveContext :: DynFlags -> InteractiveContext@@ -268,7 +310,7 @@ = InteractiveContext { ic_dflags = dflags, ic_imports = [],- ic_rn_gbl_env = emptyGlobalRdrEnv,+ ic_gre_cache = emptyIcGlobalRdrEnv, ic_mod_index = 1, ic_tythings = [], ic_instances = ([],[]),@@ -281,6 +323,9 @@ ic_plugins = [] } +icReaderEnv :: InteractiveContext -> GlobalRdrEnv+icReaderEnv = igre_env . ic_gre_cache+ icInteractiveModule :: InteractiveContext -> Module icInteractiveModule (InteractiveContext { ic_mod_index = index }) = mkInteractiveModule index@@ -292,8 +337,7 @@ -- | Get the PrintUnqualified function based on the flags and this InteractiveContext icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified-icPrintUnqual unit_env InteractiveContext{ ic_rn_gbl_env = grenv } =- mkPrintUnqualified unit_env grenv+icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. Ids are easily removed when shadowed,@@ -312,7 +356,7 @@ -- Always bump this; even instances should create -- a new mod_index (#9426) , ic_tythings = new_tythings ++ old_tythings- , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings+ , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings , ic_instances = ( new_cls_insts ++ old_cls_insts , new_fam_insts ++ fam_insts ) -- we don't shadow old family instances (#7102),@@ -333,9 +377,11 @@ -- Just a specialised version extendInteractiveContextWithIds ictxt new_ids | null new_ids = ictxt- | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1- , ic_tythings = new_tythings ++ old_tythings- , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }+ | otherwise+ = ictxt { ic_mod_index = ic_mod_index ictxt + 1+ , ic_tythings = new_tythings ++ old_tythings+ , ic_gre_cache = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings+ } where new_tythings = map AnId new_ids old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)@@ -351,8 +397,20 @@ setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} - -- ToDo: should not add Ids to the gbl env here+icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv+icExtendIcGblRdrEnv igre tythings = IcGlobalRdrEnv+ { igre_env = igre_env igre `icExtendGblRdrEnv` tythings+ , igre_prompt_env = igre_prompt_env igre `icExtendGblRdrEnv` tythings+ } +-- This is used by setContext in GHC.Runtime.Eval when the set of imports+-- changes, and recalculates the GlobalRdrEnv. See Note [icReaderEnv recalculation]+replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv+replaceImportEnv igre import_env = igre { igre_env = new_env }+ where+ import_env_shadowed = import_env `shadowNames` igre_prompt_env igre+ new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre+ -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing -- later ones, and shadowing existing entries in the GlobalRdrEnv. icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv@@ -367,7 +425,9 @@ | otherwise = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) where- env1 = shadowNames env (concatMap availGreNames avail)+ new_gres = concatMap availGreNames avail+ new_occs = occSetToEnv (mkOccSet (map occName new_gres))+ env1 = shadowNames env new_occs avail = tyThingAvailInfo thing -- Ugh! The new_tythings may include record selectors, since they@@ -397,4 +457,3 @@ instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m ppr (IIDecl d) = ppr d-
compiler/GHC/Runtime/Eval/Types.hs view
@@ -7,9 +7,9 @@ -- ----------------------------------------------------------------------------- module GHC.Runtime.Eval.Types (- Resume(..), History(..), ExecResult(..),- SingleStep(..), isStep, ExecOptions(..),- BreakInfo(..)+ Resume(..), ResumeBindings, IcGlobalRdrEnv(..),+ History(..), ExecResult(..),+ SingleStep(..), isStep, ExecOptions(..) ) where import GHC.Prelude@@ -19,7 +19,7 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing-import GHC.Unit.Module+import GHC.Types.BreakInfo import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception@@ -54,15 +54,22 @@ , breakInfo :: Maybe BreakInfo } -data BreakInfo = BreakInfo- { breakInfo_module :: Module- , breakInfo_number :: Int+-- | Essentially a GlobalRdrEnv, but with additional cached values to allow+-- efficient re-calculation when the imports change.+-- Fields are strict to avoid space leaks (see T4029)+-- All operations are in GHC.Runtime.Context.+-- See Note [icReaderEnv recalculation]+data IcGlobalRdrEnv = IcGlobalRdrEnv+ { igre_env :: !GlobalRdrEnv+ -- ^ The final environment+ , igre_prompt_env :: !GlobalRdrEnv+ -- ^ Just the things defined at the prompt (excluding imports!) } data Resume = Resume { resumeStmt :: String -- the original statement , resumeContext :: ForeignRef (ResumeContext [HValueRef])- , resumeBindings :: ([TyThing], GlobalRdrEnv)+ , resumeBindings :: ResumeBindings , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables.@@ -80,6 +87,8 @@ , resumeHistory :: [History] , resumeHistoryIx :: Int -- 0 <==> at the top of the history }++type ResumeBindings = ([TyThing], IcGlobalRdrEnv) data History = History {
compiler/GHC/Runtime/Interpreter.hs view
@@ -66,7 +66,7 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Runtime.Eval.Types(BreakInfo(..))+import GHC.Types.BreakInfo (BreakInfo(..)) import GHC.ByteCode.Types import GHC.Linker.Types@@ -724,10 +724,15 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi | Just linkable <- hm_linkable hmi,- [BCOs cbc _] <- linkableUnlinked linkable+ [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise = emptyModBreaks -- probably object code+ where+ -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.+ onlyBCOs :: Unlinked -> Maybe CompiledByteCode+ onlyBCOs (BCOs cbc _) = Just cbc+ onlyBCOs _ = Nothing -- | Interpreter uses Profiling way interpreterProfiled :: Interp -> Bool
compiler/GHC/Settings.hs view
@@ -58,10 +58,7 @@ , sExtraGccViaCFlags , sTargetPlatformString , sGhcWithInterpreter- , sGhcWithSMP- , sGhcRTSWays , sLibFFI- , sGhcRtsWithLibdw ) where import GHC.Prelude@@ -268,11 +265,5 @@ sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc sGhcWithInterpreter :: Settings -> Bool sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc-sGhcWithSMP :: Settings -> Bool-sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc-sGhcRTSWays :: Settings -> String-sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc-sGhcRtsWithLibdw :: Settings -> Bool-sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc
compiler/GHC/Stg/Syntax.hs view
@@ -829,6 +829,9 @@ pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op +instance Outputable StgOp where+ ppr = pprStgOp+ instance Outputable AltType where ppr PolyAlt = text "Polymorphic" ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
compiler/GHC/Tc/Errors/Hole/FitTypes.hs view
@@ -42,7 +42,12 @@ data HoleFitCandidate = IdHFCand Id -- An id, like locals. | NameHFCand Name -- A name, like built-in syntax. | GreHFCand GlobalRdrElt -- A global, like imported ids.- deriving (Eq)++instance Eq HoleFitCandidate where+ IdHFCand i1 == IdHFCand i2 = i1 == i2+ NameHFCand n1 == NameHFCand n2 = n1 == n2+ GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2+ _ == _ = False instance Outputable HoleFitCandidate where ppr = pprHoleFitCand
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -2,37 +2,42 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage {-# LANGUAGE RecordWildCards #-} -module GHC.Tc.Errors.Ppr (- formatLevPolyErr- , pprLevityPolyInType- ) where+module GHC.Tc.Errors.Ppr ( pprTypeDoesNotHaveFixedRuntimeRep )+ where import GHC.Prelude +import Data.Maybe (isJust)++import GHC.Builtin.Names import GHC.Core.Class (Class(..)) import GHC.Core.Coercion (pprCoAxBranchUser) import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)+import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (famInstAxiom) import GHC.Core.InstEnv-import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType, pprWithTYPE, pprWithExplicitKindsWhen)+import GHC.Core.TyCon (isNewTyCon)+import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType,+ pprWithExplicitKindsWhen, pprTheta, pprClassPred, pprTypeApp,+ pprSourceTyCon) import GHC.Core.Type import GHC.Data.Bag import GHC.Tc.Errors.Types import GHC.Tc.Types.Rank (Rank(..))-import GHC.Tc.Utils.TcType (tcSplitForAllTyVars)+import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars, mkClassPred) import GHC.Types.Error-import GHC.Types.FieldLabel (flIsOverloaded, flSelector)+import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector) import GHC.Types.Id (isRecordSelector) import GHC.Types.Name import GHC.Types.Name.Reader (GreName(..), pprNameProvenance)-import GHC.Types.SrcLoc (GenLocated(..))+import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Types.TyThing import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Types.Var.Set (pprVarSet, pluralVarSet) import GHC.Driver.Flags import GHC.Hs-import GHC.Utils.Outputable import GHC.Utils.Misc (capitalise)+import GHC.Utils.Outputable import GHC.Unit.State (pprWithUnitState, UnitState) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE@@ -42,8 +47,8 @@ diagnosticMessage = \case TcRnUnknownMessage m -> diagnosticMessage m- TcLevityPolyInType ty prov (ErrInfo extra supplementary)- -> mkDecorated [pprLevityPolyInType ty prov, extra, supplementary]+ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)+ -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] TcRnMessageWithInfo unit_state msg_with_info -> case msg_with_info of TcRnMessageDetailed err_info msg@@ -398,11 +403,125 @@ ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl | otherwise = ppr (flSelector fl) ppr_name (NormalGreName name) = ppr name+ TcRnAmbiguousField rupd parent_type+ -> mkSimpleDecorated $+ vcat [ text "The record update" <+> ppr rupd+ <+> text "with type" <+> ppr parent_type+ <+> text "is ambiguous."+ , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."+ ]+ TcRnMissingFields con fields+ -> mkSimpleDecorated $ vcat [header, nest 2 rest]+ where+ rest | null fields = empty+ | otherwise = vcat (fmap pprField fields)+ header = text "Fields of" <+> quotes (ppr con) <+>+ text "not initialised" <>+ if null fields then empty else colon+ TcRnFieldUpdateInvalidType prs+ -> mkSimpleDecorated $+ hang (text "Record update for insufficiently polymorphic field"+ <> plural prs <> colon)+ 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+ TcRnNoConstructorHasAllFields conflictingFields+ -> mkSimpleDecorated $+ hang (text "No constructor has all these fields:")+ 2 (pprQuotedList conflictingFields)+ TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels+ -> mkSimpleDecorated $+ text "Cannot use a mixture of pattern synonym and record selectors" $$+ text "Record selectors defined by"+ <+> quotes (ppr data_name)+ <> colon+ <+> pprWithCommas ppr data_sels $$+ text "Pattern synonym selectors defined by"+ <+> quotes (ppr pat_name)+ <> colon+ <+> pprWithCommas ppr pat_syn_sels+ TcRnMissingStrictFields con fields+ -> mkSimpleDecorated $ vcat [header, nest 2 rest]+ where+ rest | null fields = empty -- Happens for non-record constructors+ -- with strict fields+ | otherwise = vcat (fmap pprField fields) + header = text "Constructor" <+> quotes (ppr con) <+>+ text "does not have the required strict field(s)" <>+ if null fields then empty else colon+ TcRnNoPossibleParentForFields rbinds+ -> mkSimpleDecorated $+ hang (text "No type has all these fields:")+ 2 (pprQuotedList fields)+ where fields = map (hfbLHS . unLoc) rbinds+ TcRnBadOverloadedRecordUpdate _rbinds+ -> mkSimpleDecorated $+ text "Record update is ambiguous, and requires a type signature"+ TcRnStaticFormNotClosed name reason+ -> mkSimpleDecorated $+ quotes (ppr name)+ <+> text "is used in a static form but it is not closed"+ <+> text "because it"+ $$ sep (causes reason)+ where+ causes :: NotClosedReason -> [SDoc]+ causes NotLetBoundReason = [text "is not let-bound."]+ causes (NotTypeClosed vs) =+ [ text "has a non-closed type because it contains the"+ , text "type variables:" <+>+ pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))+ ]+ causes (NotClosed n reason) =+ let msg = text "uses" <+> quotes (ppr n) <+> text "which"+ in case reason of+ NotClosed _ _ -> msg : causes reason+ _ -> let (xs0, xs1) = splitAt 1 $ causes reason+ in fmap (msg <+>) xs0 ++ xs1+ TcRnUselessTypeable+ -> mkSimpleDecorated $+ text "Deriving" <+> quotes (ppr typeableClassName) <+>+ text "has no effect: all types now auto-derive Typeable"+ TcRnDerivingDefaults cls+ -> mkSimpleDecorated $ sep+ [ text "Both DeriveAnyClass and"+ <+> text "GeneralizedNewtypeDeriving are enabled"+ , text "Defaulting to the DeriveAnyClass strategy"+ <+> text "for instantiating" <+> ppr cls+ ]+ TcRnNonUnaryTypeclassConstraint ct+ -> mkSimpleDecorated $+ quotes (ppr ct)+ <+> text "is not a unary constraint, as expected by a deriving clause"+ TcRnPartialTypeSignatures _ theta+ -> mkSimpleDecorated $+ text "Found type wildcard" <+> quotes (char '_')+ <+> text "standing for" <+> quotes (pprTheta theta)+ TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason+ -> mkSimpleDecorated $+ derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason+ TcRnLazyGADTPattern+ -> mkSimpleDecorated $+ hang (text "An existential or GADT data constructor cannot be used")+ 2 (text "inside a lazy (~) pattern")+ TcRnArrowProcGADTPattern+ -> mkSimpleDecorated $+ text "Proc patterns cannot use existential or GADT data constructors"++ TcRnSpecialClassInst cls because_safeHaskell+ -> mkSimpleDecorated $+ text "Class" <+> quotes (ppr $ className cls)+ <+> text "does not support user-specified instances"+ <> safeHaskell_msg+ where+ safeHaskell_msg+ | because_safeHaskell+ = text " when Safe Haskell is enabled."+ | otherwise+ = dot+ diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m- TcLevityPolyInType{}+ TcRnTypeDoesNotHaveFixedRuntimeRep{} -> ErrorWithoutFlag TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of@@ -553,11 +672,72 @@ -> ErrorWithoutFlag TcRnConflictingExports{} -> ErrorWithoutFlag+ TcRnAmbiguousField{}+ -> WarningWithFlag Opt_WarnAmbiguousFields+ TcRnMissingFields{}+ -> WarningWithFlag Opt_WarnMissingFields+ TcRnFieldUpdateInvalidType{}+ -> ErrorWithoutFlag+ TcRnNoConstructorHasAllFields{}+ -> ErrorWithoutFlag+ TcRnMixedSelectors{}+ -> ErrorWithoutFlag+ TcRnMissingStrictFields{}+ -> ErrorWithoutFlag+ TcRnNoPossibleParentForFields{}+ -> ErrorWithoutFlag+ TcRnBadOverloadedRecordUpdate{}+ -> ErrorWithoutFlag+ TcRnStaticFormNotClosed{}+ -> ErrorWithoutFlag+ TcRnUselessTypeable+ -> WarningWithFlag Opt_WarnDerivingTypeable+ TcRnDerivingDefaults{}+ -> WarningWithFlag Opt_WarnDerivingDefaults+ TcRnNonUnaryTypeclassConstraint{}+ -> ErrorWithoutFlag+ TcRnPartialTypeSignatures{}+ -> WarningWithFlag Opt_WarnPartialTypeSignatures+ TcRnCannotDeriveInstance _ _ _ _ rea+ -> case rea of+ DerivErrNotWellKinded{} -> ErrorWithoutFlag+ DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag+ DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag+ DerivErrNoEtaReduce{} -> ErrorWithoutFlag+ DerivErrBootFileFound -> ErrorWithoutFlag+ DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag+ DerivErrGNDUsedOnData -> ErrorWithoutFlag+ DerivErrNullaryClasses -> ErrorWithoutFlag+ DerivErrLastArgMustBeApp -> ErrorWithoutFlag+ DerivErrNoFamilyInstance{} -> ErrorWithoutFlag+ DerivErrNotStockDeriveable{} -> ErrorWithoutFlag+ DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag+ DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag+ DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag+ DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag+ DerivErrNotDeriveable{} -> ErrorWithoutFlag+ DerivErrNotAClass{} -> ErrorWithoutFlag+ DerivErrNoConstructors{} -> ErrorWithoutFlag+ DerivErrLangExtRequired{} -> ErrorWithoutFlag+ DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag+ DerivErrMustBeEnumType{} -> ErrorWithoutFlag+ DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag+ DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag+ DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag+ DerivErrBadConstructor{} -> ErrorWithoutFlag+ DerivErrGenerics{} -> ErrorWithoutFlag+ DerivErrEnumOrProduct{} -> ErrorWithoutFlag+ TcRnLazyGADTPattern+ -> ErrorWithoutFlag+ TcRnArrowProcGADTPattern+ -> ErrorWithoutFlag+ TcRnSpecialClassInst {}+ -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m -> diagnosticHints m- TcLevityPolyInType{}+ TcRnTypeDoesNotHaveFixedRuntimeRep{} -> noHints TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of@@ -724,7 +904,127 @@ -> noHints TcRnConflictingExports{} -> noHints+ TcRnAmbiguousField{}+ -> noHints+ TcRnMissingFields{}+ -> noHints+ TcRnFieldUpdateInvalidType{}+ -> noHints+ TcRnNoConstructorHasAllFields{}+ -> noHints+ TcRnMixedSelectors{}+ -> noHints+ TcRnMissingStrictFields{}+ -> noHints+ TcRnNoPossibleParentForFields{}+ -> noHints+ TcRnBadOverloadedRecordUpdate{}+ -> noHints+ TcRnStaticFormNotClosed{}+ -> noHints+ TcRnUselessTypeable+ -> noHints+ TcRnDerivingDefaults{}+ -> [useDerivingStrategies]+ TcRnNonUnaryTypeclassConstraint{}+ -> noHints+ TcRnPartialTypeSignatures suggestParSig _+ -> case suggestParSig of+ YesSuggestPartialTypeSignatures+ -> let info = text "to use the inferred type"+ in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]+ NoSuggestPartialTypeSignatures+ -> noHints+ TcRnCannotDeriveInstance cls _ _ newtype_deriving rea+ -> deriveInstanceErrReasonHints cls newtype_deriving rea+ TcRnLazyGADTPattern+ -> noHints+ TcRnArrowProcGADTPattern+ -> noHints+ TcRnSpecialClassInst {}+ -> noHints +deriveInstanceErrReasonHints :: Class+ -> UsingGeneralizedNewtypeDeriving+ -> DeriveInstanceErrReason+ -> [GhcHint]+deriveInstanceErrReasonHints cls newtype_deriving = \case+ DerivErrNotWellKinded _ _ n_args_to_keep+ | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0+ -> [suggestExtension LangExt.PolyKinds]+ | otherwise+ -> noHints+ DerivErrSafeHaskellGenericInst -> noHints+ DerivErrDerivingViaWrongKind{} -> noHints+ DerivErrNoEtaReduce{} -> noHints+ DerivErrBootFileFound -> noHints+ DerivErrDataConsNotAllInScope{} -> noHints+ DerivErrGNDUsedOnData -> noHints+ DerivErrNullaryClasses -> noHints+ DerivErrLastArgMustBeApp -> noHints+ DerivErrNoFamilyInstance{} -> noHints+ DerivErrNotStockDeriveable deriveAnyClassEnabled+ | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+ -> [suggestExtension LangExt.DeriveAnyClass]+ | otherwise+ -> noHints+ DerivErrHasAssociatedDatatypes{}+ -> noHints+ DerivErrNewtypeNonDeriveableClass+ | newtype_deriving == NoGeneralizedNewtypeDeriving+ -> [useGND]+ | otherwise+ -> noHints+ DerivErrCannotEtaReduceEnough{}+ | newtype_deriving == NoGeneralizedNewtypeDeriving+ -> [useGND]+ | otherwise+ -> noHints+ DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled+ | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+ -> [suggestExtension LangExt.DeriveAnyClass]+ | otherwise+ -> noHints+ DerivErrNotDeriveable deriveAnyClassEnabled+ | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+ -> [suggestExtension LangExt.DeriveAnyClass]+ | otherwise+ -> noHints+ DerivErrNotAClass{}+ -> noHints+ DerivErrNoConstructors{}+ -> let info = text "to enable deriving for empty data types"+ in [useExtensionInOrderTo info LangExt.EmptyDataDeriving]+ DerivErrLangExtRequired{}+ -- This is a slightly weird corner case of GHC: we are failing+ -- to derive a typeclass instance because a particular 'Extension'+ -- is not enabled (and so we report in the main error), but here+ -- we don't want to /repeat/ to enable the extension in the hint.+ -> noHints+ DerivErrDunnoHowToDeriveForType{}+ -> noHints+ DerivErrMustBeEnumType rep_tc+ -- We want to suggest GND only if this /is/ a newtype.+ | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc+ -> [useGND]+ | otherwise+ -> noHints+ DerivErrMustHaveExactlyOneConstructor{}+ -> noHints+ DerivErrMustHaveSomeParameters{}+ -> noHints+ DerivErrMustNotHaveClassContext{}+ -> noHints+ DerivErrBadConstructor wcard _+ -> case wcard of+ Nothing -> noHints+ Just YesHasWildcard -> [SuggestFillInWildcardConstraint]+ Just NoHasWildcard -> [SuggestAddStandaloneDerivation]+ DerivErrGenerics{}+ -> noHints+ DerivErrEnumOrProduct{}+ -> noHints+ messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo -> DecoratedSDoc@@ -748,47 +1048,22 @@ ii :: LIEWrappedName (IdP (GhcPass p)) ii = noLocA (IEName $ noLocA tc) -formatLevPolyErr :: Type -- representation-polymorphic type- -> SDoc-formatLevPolyErr ty- = hang (text "A representation-polymorphic type is not allowed here:")- 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty- , text "Kind:" <+> pprWithTYPE tidy_ki ])+pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc+pprTypeDoesNotHaveFixedRuntimeRep ty prov =+ let what = pprFixedRuntimeRepProvenance prov+ in text "The" <+> what <+> text "does not have a fixed runtime representation:"+ $$ format_frr_err ty++format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation+ -> SDoc+format_frr_err ty+ = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki) where (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty tidy_ki = tidyType tidy_env (tcTypeKind ty) -pprLevityPolyInType :: Type -> LevityCheckProvenance -> SDoc-pprLevityPolyInType ty prov =- let extra = case prov of- LevityCheckInBinder v- -> text "In the type of binder" <+> quotes (ppr v)- LevityCheckInVarType- -> text "When trying to create a variable of type:" <+> ppr ty- LevityCheckInWildcardPattern- -> text "In a wildcard pattern"- LevityCheckInUnboxedTuplePattern p- -> text "In the type of an element of an unboxed tuple pattern:" $$ ppr p- LevityCheckPatSynSig- -> empty- LevityCheckCmdStmt- -> empty -- I (Richard E, Dec '16) have no idea what to say here- LevityCheckMkCmdEnv id_var- -> text "In the result of the function" <+> quotes (ppr id_var)- LevityCheckDoCmd do_block- -> text "In the do-command:" <+> ppr do_block- LevityCheckDesugaringCmd cmd- -> text "When desugaring the command:" <+> ppr cmd- LevityCheckInCmd body- -> text "In the command:" <+> ppr body- LevityCheckInFunUse using- -> text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using- LevityCheckInValidDataCon- -> empty- LevityCheckInValidClass- -> empty- in formatLevPolyErr ty $$ extra-+pprField :: (FieldLabelString, TcType) -> SDoc+pprField (f,ty) = ppr f <+> dcolon <+> ppr ty pprRecordFieldPart :: RecordFieldPart -> SDoc pprRecordFieldPart = \case@@ -808,3 +1083,210 @@ hsep [ text "The export item" , quotes exportedThing , text reason ]++useDerivingStrategies :: GhcHint+useDerivingStrategies =+ useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies++useGND :: GhcHint+useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"+ in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving++cannotMakeDerivedInstanceHerald :: Class+ -> [Type]+ -> Maybe (DerivStrategy GhcTc)+ -> UsingGeneralizedNewtypeDeriving+ -> Bool -- ^ If False, only prints the why.+ -> SDoc+ -> SDoc+cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =+ if pprHerald+ then sep [(hang (text "Can't make a derived instance of")+ 2 (quotes (ppr pred) <+> via_mechanism)+ $$ nest 2 extra) <> colon,+ nest 2 why]+ else why+ where+ strat_used = isJust mb_strat+ extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)+ = text "(even with cunning GeneralizedNewtypeDeriving)"+ | otherwise = empty+ pred = mkClassPred cls cls_args+ via_mechanism | strat_used+ , Just strat <- mb_strat+ = text "with the" <+> (derivStrategyName strat) <+> text "strategy"+ | otherwise+ = empty++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++derivErrDiagnosticMessage :: Class+ -> [Type]+ -> Maybe (DerivStrategy GhcTc)+ -> UsingGeneralizedNewtypeDeriving+ -> Bool -- If True, includes the herald \"can't make a derived..\"+ -> DeriveInstanceErrReason+ -> SDoc+derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case+ DerivErrNotWellKinded tc cls_kind _+ -> sep [ hang (text "Cannot derive well-kinded instance of form"+ <+> quotes (pprClassPred cls cls_tys+ <+> parens (ppr tc <+> text "...")))+ 2 empty+ , nest 2 (text "Class" <+> quotes (ppr cls)+ <+> text "expects an argument of kind"+ <+> quotes (pprKind cls_kind))+ ]+ DerivErrSafeHaskellGenericInst+ -> text "Generic instances can only be derived in"+ <+> text "Safe Haskell using the stock strategy."+ DerivErrDerivingViaWrongKind cls_kind via_ty via_kind+ -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+ 2 (text "Class" <+> quotes (ppr cls)+ <+> text "expects an argument of kind"+ <+> quotes (pprKind cls_kind) <> char ','+ $+$ text "but" <+> quotes (pprType via_ty)+ <+> text "has kind" <+> quotes (pprKind via_kind))+ DerivErrNoEtaReduce inst_ty+ -> sep [text "Cannot eta-reduce to an instance of form",+ nest 2 (text "instance (...) =>"+ <+> pprClassPred cls (cls_tys ++ [inst_ty]))]+ DerivErrBootFileFound+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "Cannot derive instances in hs-boot files"+ $+$ text "Write an instance declaration instead")+ DerivErrDataConsNotAllInScope tc+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")+ 2 (text "so you cannot derive an instance for it"))+ DerivErrGNDUsedOnData+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")+ DerivErrNullaryClasses+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "Cannot derive instances for nullary classes")+ DerivErrLastArgMustBeApp+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ ( text "The last argument of the instance must be a"+ <+> text "data or newtype application")+ DerivErrNoFamilyInstance tc tc_args+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))+ DerivErrNotStockDeriveable _+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")+ DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg+ , case at_without_last_cls_tv of+ YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc+ NoAssociatedTyNotParamOverLastTyVar -> empty+ , case at_last_cls_tv_in_kinds of+ YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc+ NoAssocTyLastVarInKind -> empty+ ]+ where++ adfs_msg = text "the class has associated data types"++ at_without_last_cls_tv_msg at_tc = hang+ (text "the associated type" <+> quotes (ppr at_tc)+ <+> text "is not parameterized over the last type variable")+ 2 (text "of the class" <+> quotes (ppr cls))++ at_last_cls_tv_in_kinds_msg at_tc = hang+ (text "the associated type" <+> quotes (ppr at_tc)+ <+> text "contains the last type variable")+ 2 (text "of the class" <+> quotes (ppr cls)+ <+> text "in a kind, which is not (yet) allowed")+ DerivErrNewtypeNonDeriveableClass+ -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)+ DerivErrCannotEtaReduceEnough eta_ok+ -> let cant_derive_err = ppUnless eta_ok eta_msg+ eta_msg = text "cannot eta-reduce the representation type enough"+ in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ cant_derive_err+ DerivErrOnlyAnyClassDeriveable tc _+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (quotes (ppr tc) <+> text "is a type class,"+ <+> text "and can only have a derived instance"+ $+$ text "if DeriveAnyClass is enabled")+ DerivErrNotDeriveable _+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty+ DerivErrNotAClass predType+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (quotes (ppr predType) <+> text "is not a class")+ DerivErrNoConstructors rep_tc+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")+ DerivErrLangExtRequired ext+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "You need " <> ppr ext+ <+> text "to derive an instance for this class")+ DerivErrDunnoHowToDeriveForType ty+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (hang (text "Don't know how to derive" <+> quotes (ppr cls))+ 2 (text "for type" <+> quotes (ppr ty)))+ DerivErrMustBeEnumType rep_tc+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (sep [ quotes (pprSourceTyCon rep_tc) <+>+ text "must be an enumeration type"+ , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])++ DerivErrMustHaveExactlyOneConstructor rep_tc+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")+ DerivErrMustHaveSomeParameters rep_tc+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")+ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta+ -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (text "Data type" <+> quotes (ppr rep_tc)+ <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+ DerivErrBadConstructor _ reasons+ -> let why = vcat $ map renderReason reasons+ in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+ where+ renderReason = \case+ DerivErrBadConExistential con+ -> badCon con $ text "must be truly polymorphic in the last argument of the data type"+ DerivErrBadConCovariant con+ -> badCon con $ text "must not use the type variable in a function argument"+ DerivErrBadConFunTypes con+ -> badCon con $ text "must not contain function types"+ DerivErrBadConWrongArg con+ -> badCon con $ text "must use the type variable only as the last argument of a data type"+ DerivErrBadConIsGADT con+ -> badCon con $ text "is a GADT"+ DerivErrBadConHasExistentials con+ -> badCon con $ text "has existential type variables in its type"+ DerivErrBadConHasConstraints con+ -> badCon con $ text "has constraints in its type"+ DerivErrBadConHasHigherRankType con+ -> badCon con $ text "has a higher-rank type"+ DerivErrGenerics reasons+ -> let why = vcat $ map renderReason reasons+ in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+ where+ renderReason = \case+ DerivErrGenericsMustNotHaveDatatypeContext tc_name+ -> ppr tc_name <+> text "must not have a datatype context"+ DerivErrGenericsMustNotHaveExoticArgs dc+ -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"+ DerivErrGenericsMustBeVanillaDataCon dc+ -> ppr dc <+> text "must be a vanilla data constructor"+ DerivErrGenericsMustHaveSomeTypeParams rep_tc+ -> text "Data type" <+> quotes (ppr rep_tc)+ <+> text "must have some type parameters"+ DerivErrGenericsMustNotHaveExistentials con+ -> badCon con $ text "must not have existential arguments"+ DerivErrGenericsWrongArgKind con+ -> badCon con $+ text "applies a type to an argument involving the last parameter"+ $$ text "but the applied type is not of kind * -> *"+ DerivErrEnumOrProduct this that+ -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this+ ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that+ in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+ (ppr1 $$ text " or" $$ ppr2)
compiler/GHC/Tc/Errors/Types.hs view
@@ -4,7 +4,8 @@ TcRnMessage(..) , TcRnMessageDetailed(..) , ErrInfo(..)- , LevityCheckProvenance(..)+ , FixedRuntimeRepProvenance(..)+ , pprFixedRuntimeRepProvenance , ShadowedNameProvenance(..) , RecordFieldPart(..) , InjectivityErrReason(..)@@ -12,6 +13,24 @@ , hasKinds , SuggestUndecidableInstances(..) , suggestUndecidableInstances+ , NotClosedReason(..)+ , SuggestPartialTypeSignatures(..)+ , suggestPartialTypeSignatures+ , DeriveInstanceErrReason(..)+ , UsingGeneralizedNewtypeDeriving(..)+ , usingGeneralizedNewtypeDeriving+ , DeriveAnyClassEnabled(..)+ , deriveAnyClassEnabled+ , DeriveInstanceBadConstructor(..)+ , HasWildcard(..)+ , hasWildcard+ , DeriveGenericsErrReason(..)+ , HasAssociatedDataFamInsts(..)+ , hasAssociatedDataFamInsts+ , AssociatedTyLastVarInKind(..)+ , associatedTyLastVarInKind+ , AssociatedTyNotParamOverLastTyVar(..)+ , associatedTyNotParamOverLastTyVar ) where import GHC.Prelude@@ -20,23 +39,29 @@ import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) import GHC.Tc.Types.Constraint import GHC.Tc.Types.Rank (Rank)+import GHC.Tc.Utils.TcType (TcType) import GHC.Types.Error+import GHC.Types.FieldLabel (FieldLabelString) import GHC.Types.Name (Name, OccName) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing)+import GHC.Types.Var (Id)+import GHC.Types.Var.Set (TyVarSet, VarSet) import GHC.Unit.Types (Module) import GHC.Utils.Outputable import GHC.Core.Class (Class) import GHC.Core.Coercion.Axiom (CoAxBranch)+import GHC.Core.ConLike (ConLike)+import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (ClsInst) import GHC.Core.TyCon (TyCon, TyConFlavour)-import GHC.Core.Type (Kind, Type, Var)+import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic-import GHC.Types.Var.Set (TyVarSet)+import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon)@@ -113,12 +138,21 @@ -> !TcRnMessageDetailed -> TcRnMessage - {-| A levity polymorphism check happening during TcRn.+ {-| A type which was expected to have a fixed runtime representation+ does not have a fixed runtime representation.++ Example:++ data D (a :: TYPE r) = MkD a++ Test cases: T11724, T18534,+ RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype,+ RepPolyPatSynRes, T20423 -}- TcLevityPolyInType :: !Type- -> !LevityCheckProvenance- -> !ErrInfo -- Extra info accumulated in the TcM monad- -> TcRnMessage+ TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type+ -> !FixedRuntimeRepProvenance+ -> !ErrInfo -- Extra info accumulated in the TcM monad+ -> TcRnMessage {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when a Template Haskell quote implicitly uses 'lift'.@@ -1097,6 +1131,287 @@ -> IE GhcPs -- ^ Export decl of second export -> TcRnMessage + {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring+ when a record update's type cannot be precisely determined. This will not+ be supported by -XDuplicateRecordFields in future releases.++ Example(s):+ data Person = MkPerson { personId :: Int, name :: String }+ data Address = MkAddress { personId :: Int, address :: String }+ bad1 x = x { personId = 4 } :: Person -- ambiguous+ bad2 (x :: Person) = x { personId = 4 } -- ambiguous+ good x = (x :: Person) { personId = 4 } -- not ambiguous++ Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06+ -}+ TcRnAmbiguousField+ :: HsExpr GhcRn -- ^ Field update+ -> TyCon -- ^ Record type+ -> TcRnMessage++ {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring+ when the intialisation of a record is missing one or more (lazy) fields.++ Example(s):+ data Rec = Rec { a :: Int, b :: String, c :: Bool }+ x = Rec { a = 1, b = "two" } -- missing field 'c'++ Test cases: deSugar/should_compile/T13870+ deSugar/should_compile/ds041+ patsyn/should_compile/T11283+ rename/should_compile/T5334+ rename/should_compile/T12229+ rename/should_compile/T5892a+ warnings/should_fail/WerrorFail2+ -}+ TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++ {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's+ type mentions something that is outside the universally quantified variables+ of the data constructor, such as an existentially quantified type.++ Example(s):+ data X = forall a. MkX { f :: a }+ x = (MkX ()) { f = False }++ Test cases: patsyn/should_fail/records-exquant+ typecheck/should_fail/T3323+ -}+ TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage++ {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update+ has fields that no single constructor encompasses.++ Example(s):+ data Foo = A { x :: Bool }+ | B { y :: Int }+ foo = (A False) { x = True, y = 5 }++ Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08+ patsyn/should_fail/mixed-pat-syn-record-sels+ typecheck/should_fail/T7989+ -}+ TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage++ {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and+ record selectors are used in the same record update block.++ Example(s):+ data Rec = Rec { foo :: Int, bar :: String }+ pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 }+ illegal :: Rec -> Rec+ illegal r = r { f1 = 1, bar = "two" }++ Test cases: patsyn/should_fail/records-mixing-fields+ -}+ TcRnMixedSelectors+ :: Name -- ^ Record+ -> [Id] -- ^ Record selectors+ -> Name -- ^ Pattern synonym+ -> [Id] -- ^ Pattern selectors+ -> TcRnMessage++ {- TcRnMissingStrictFields is an error occurring when a record field marked+ as strict is omitted when constructing said record.++ Example(s):+ data R = R { strictField :: !Bool, nonStrict :: Int }+ x = R { nonStrict = 1 }++ Test cases: typecheck/should_fail/T18869+ typecheck/should_fail/tcfail085+ typecheck/should_fail/tcfail112+ -}+ TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++ {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a+ record update block do not all belong to any one type.++ Example(s):+ data R1 = R1 { x :: Int, y :: Int }+ data R2 = R2 { y :: Int, z :: Int }+ update r = r { x = 1, y = 2, z = 3 }++ Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01+ overloadedrecflds/should_fail/overloadedrecfldsfail14+ -}+ TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage++ {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot+ be pinned down to any one constructor and thus must be given a type signature.++ Example(s):+ data R1 = R1 { x :: Int }+ data R2 = R2 { x :: Int }+ update r = r { x = 1 } -- needs a type signature++ Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01+ -}+ TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage++ {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static+ using the -XStaticPointers extension but which are not closed terms.++ Example(s):+ f x = static x++ Test cases: rename/should_fail/RnStaticPointersFail01+ rename/should_fail/RnStaticPointersFail03+ -}+ TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage+ {-| TcRnSpecialClassInst is an error that occurs when a user+ attempts to define an instance for a built-in typeclass such as+ 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file.++ Test cases: deriving/should_fail/T9687+ deriving/should_fail/T14916+ polykinds/T8132+ typecheck/should_fail/TcCoercibleFail2+ typecheck/should_fail/T12837+ typecheck/should_fail/T14390++ -}+ TcRnSpecialClassInst :: !Class+ -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled+ -> TcRnMessage++ {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that+ occurs when trying to derive an instance of the 'Typeable' class. Deriving+ 'Typeable' is no longer necessary (hence the \"useless\") as all types+ automatically derive 'Typeable' in modern GHC versions.++ Example(s): None.++ Test cases: warnings/should_compile/DerivingTypeable+ -}+ TcRnUselessTypeable :: TcRnMessage++ {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that+ occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are+ enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not+ be what the user wants.++ Example(s): None.++ Test cases: typecheck/should_compile/T15839a+ deriving/should_compile/T16179+ -}+ TcRnDerivingDefaults :: !Class -> TcRnMessage++ {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC+ encounters a non-unary constraint when trying to derive a typeclass.++ Example(s):+ class A+ deriving instance A+ data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a').++ Test cases: deriving/should_fail/T7959+ deriving/should_fail/drvfail005+ deriving/should_fail/drvfail009+ deriving/should_fail/drvfail006+ -}+ TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage++ {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures)+ that occurs when a wildcard '_' is found in place of a type in a signature or a+ type class derivation++ Example(s):+ foo :: _ -> Int+ foo = ...++ deriving instance _ => Eq (Foo a)++ Test cases: dependent/should_compile/T11241+ dependent/should_compile/T15076+ dependent/should_compile/T14880-2+ typecheck/should_compile/T17024+ typecheck/should_compile/T10072+ partial-sigs/should_fail/TidyClash2+ partial-sigs/should_fail/Defaulting1MROff+ partial-sigs/should_fail/WildcardsInPatternAndExprSig+ partial-sigs/should_fail/T10615+ partial-sigs/should_fail/T14584a+ partial-sigs/should_fail/TidyClash+ partial-sigs/should_fail/T11122+ partial-sigs/should_fail/T14584+ partial-sigs/should_fail/T10045+ partial-sigs/should_fail/PartialTypeSignaturesDisabled+ partial-sigs/should_fail/T10999+ partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature+ partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice+ partial-sigs/should_fail/WildcardInstantiations+ partial-sigs/should_run/T15415+ partial-sigs/should_compile/T10463+ partial-sigs/should_compile/T15039a+ partial-sigs/should_compile/T16728b+ partial-sigs/should_compile/T15039c+ partial-sigs/should_compile/T10438+ partial-sigs/should_compile/SplicesUsed+ partial-sigs/should_compile/T18008+ partial-sigs/should_compile/ExprSigLocal+ partial-sigs/should_compile/T11339a+ partial-sigs/should_compile/T11670+ partial-sigs/should_compile/WarningWildcardInstantiations+ partial-sigs/should_compile/T16728+ partial-sigs/should_compile/T12033+ partial-sigs/should_compile/T15039b+ partial-sigs/should_compile/T10403+ partial-sigs/should_compile/T11192+ partial-sigs/should_compile/T16728a+ partial-sigs/should_compile/TypedSplice+ partial-sigs/should_compile/T15039d+ partial-sigs/should_compile/T11016+ partial-sigs/should_compile/T13324_compile2+ linear/should_fail/LinearPartialSig+ polykinds/T14265+ polykinds/T14172+ -}+ TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage++ {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance+ can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason+ this error arose.++ Example(s): None.++ Test cases: generics/T10604/T10604_no_PolyKinds+ deriving/should_fail/drvfail009+ deriving/should_fail/drvfail-functor2+ deriving/should_fail/T10598_fail3+ deriving/should_fail/deriving-via-fail2+ deriving/should_fail/deriving-via-fail+ deriving/should_fail/T16181+ -}+ TcRnCannotDeriveInstance :: !Class+ -- ^ The typeclass we are trying to derive+ -- an instance for+ -> [Type]+ -- ^ The typeclass arguments, if any.+ -> !(Maybe (DerivStrategy GhcTc))+ -- ^ The derivation strategy, if any.+ -> !UsingGeneralizedNewtypeDeriving+ -- ^ Is '-XGeneralizedNewtypeDeriving' enabled?+ -> !DeriveInstanceErrReason+ -- ^ The specific reason why we couldn't derive+ -- an instance for the class.+ -> TcRnMessage++ {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested+ GADT pattern match inside a lazy (~) pattern.++ Test case: gadt/lazypat+ -}+ TcRnLazyGADTPattern :: TcRnMessage++ {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a+ GADT pattern inside arrow proc notation.++ Test case: arrows/should_fail/arrowfail004.+ -}+ TcRnArrowProcGADTPattern :: TcRnMessage+ -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name@@ -1110,22 +1425,33 @@ | ShadowedNameProvenanceGlobal [GlobalRdrElt] -- ^ The shadowed name is global, typically imported from elsewhere. --- | Where the levity checking for the input type originated-data LevityCheckProvenance- = LevityCheckInVarType- | LevityCheckInBinder !Var- | LevityCheckInWildcardPattern- | LevityCheckInUnboxedTuplePattern !(Pat GhcTc)- | LevityCheckPatSynSig- | LevityCheckCmdStmt- | LevityCheckMkCmdEnv !Var- | LevityCheckDoCmd !(HsCmd GhcTc)- | LevityCheckDesugaringCmd !(LHsCmd GhcTc)- | LevityCheckInCmd !(LHsCmd GhcTc)- | LevityCheckInFunUse !(LHsExpr GhcTc)- | LevityCheckInValidDataCon- | LevityCheckInValidClass+-- | In what context did we require a type to have a fixed runtime representation?+--+-- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing+-- representation polymorphism errors when validity checking.+--+-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+data FixedRuntimeRepProvenance+ -- | Data constructor fields must have a fixed runtime representation.+ --+ -- Tests: T11734, T18534.+ = FixedRuntimeRepDataConField + -- | Pattern synonym signature arguments must have a fixed runtime representation.+ --+ -- Test: RepPolyPatSynArg.+ | FixedRuntimeRepPatSynSigArg++ -- | Pattern synonym signature scrutinee must have a fixed runtime representation.+ --+ -- Test: RepPolyPatSynRes.+ | FixedRuntimeRepPatSynSigRes++pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc+pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee"+ -- | Why the particular injectivity error arose together with more information, -- if any. data InjectivityErrReason@@ -1151,3 +1477,189 @@ suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances suggestUndecidableInstances True = YesSuggestUndecidableInstaces suggestUndecidableInstances False = NoSuggestUndecidableInstaces++-- | A data type to describe why a variable is not closed.+-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr+data NotClosedReason = NotLetBoundReason+ | NotTypeClosed VarSet+ | NotClosed Name NotClosedReason++data SuggestPartialTypeSignatures+ = YesSuggestPartialTypeSignatures+ | NoSuggestPartialTypeSignatures+ deriving (Show, Eq)++suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures+suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures+suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures++data UsingGeneralizedNewtypeDeriving+ = YesGeneralizedNewtypeDeriving+ | NoGeneralizedNewtypeDeriving+ deriving Eq++usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving++data DeriveAnyClassEnabled+ = YesDeriveAnyClassEnabled+ | NoDeriveAnyClassEnabled+ deriving Eq++deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled+deriveAnyClassEnabled True = YesDeriveAnyClassEnabled+deriveAnyClassEnabled False = NoDeriveAnyClassEnabled++-- | Why a particular typeclass instance couldn't be derived.+data DeriveInstanceErrReason+ =+ -- | The typeclass instance is not well-kinded.+ DerivErrNotWellKinded !TyCon+ -- ^ The type constructor that occurs in+ -- the typeclass instance declaration.+ !Kind+ -- ^ The typeclass kind.+ !Int+ -- ^ The number of typeclass arguments that GHC+ -- kept. See Note [tc_args and tycon arity] in+ -- GHC.Tc.Deriv.+ -- | Generic instances can only be derived using the stock strategy+ -- in Safe Haskell.+ | DerivErrSafeHaskellGenericInst+ | DerivErrDerivingViaWrongKind !Kind !Type !Kind+ | DerivErrNoEtaReduce !Type+ -- ^ The instance type+ -- | We cannot derive instances in boot files+ | DerivErrBootFileFound+ | DerivErrDataConsNotAllInScope !TyCon+ -- | We cannot use GND on non-newtype types+ | DerivErrGNDUsedOnData+ -- | We cannot derive instances of nullary classes+ | DerivErrNullaryClasses+ -- | Last arg must be newtype or data application+ | DerivErrLastArgMustBeApp+ | DerivErrNoFamilyInstance !TyCon [Type]+ | DerivErrNotStockDeriveable !DeriveAnyClassEnabled+ | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts+ !AssociatedTyLastVarInKind+ !AssociatedTyNotParamOverLastTyVar+ | DerivErrNewtypeNonDeriveableClass+ | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK?+ | DerivErrOnlyAnyClassDeriveable !TyCon+ -- ^ Type constructor for which the instance+ -- is requested+ !DeriveAnyClassEnabled+ -- ^ Whether or not -XDeriveAnyClass is enabled+ -- already.+ -- | Stock deriving won't work, but perhas DeriveAnyClass will.+ | DerivErrNotDeriveable !DeriveAnyClassEnabled+ -- | The given 'PredType' is not a class.+ | DerivErrNotAClass !PredType+ -- | The given (representation of the) 'TyCon' has no+ -- data constructors.+ | DerivErrNoConstructors !TyCon+ | DerivErrLangExtRequired !LangExt.Extension+ -- | GHC simply doesn't how to how derive the input 'Class' for the given+ -- 'Type'.+ | DerivErrDunnoHowToDeriveForType !Type+ -- | The given 'TyCon' must be an enumeration.+ -- See Note [Enumeration types] in GHC.Core.TyCon+ | DerivErrMustBeEnumType !TyCon+ -- | The given 'TyCon' must have /precisely/ one constructor.+ | DerivErrMustHaveExactlyOneConstructor !TyCon+ -- | The given data type must have some parameters.+ | DerivErrMustHaveSomeParameters !TyCon+ -- | The given data type must not have a class context.+ | DerivErrMustNotHaveClassContext !TyCon !ThetaType+ -- | We couldn't derive an instance for a particular data constructor+ -- for a variety of reasons.+ | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor]+ -- | We couldn't derive a 'Generic' instance for the given type for a+ -- variety of reasons+ | DerivErrGenerics [DeriveGenericsErrReason]+ -- | We couldn't derive an instance either because the type was not an+ -- enum type or because it did have more than one constructor.+ | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason++data DeriveInstanceBadConstructor+ =+ -- | The given 'DataCon' must be truly polymorphic in the+ -- last argument of the data type.+ DerivErrBadConExistential !DataCon+ -- | The given 'DataCon' must not use the type variable in a function argument"+ | DerivErrBadConCovariant !DataCon+ -- | The given 'DataCon' must not contain function types+ | DerivErrBadConFunTypes !DataCon+ -- | The given 'DataCon' must use the type variable only+ -- as the last argument of a data type+ | DerivErrBadConWrongArg !DataCon+ -- | The given 'DataCon' is a GADT so we cannot directly+ -- derive an istance for it.+ | DerivErrBadConIsGADT !DataCon+ -- | The given 'DataCon' has existentials type vars in its type.+ | DerivErrBadConHasExistentials !DataCon+ -- | The given 'DataCon' has constraints in its type.+ | DerivErrBadConHasConstraints !DataCon+ -- | The given 'DataCon' has a higher-rank type.+ | DerivErrBadConHasHigherRankType !DataCon++data DeriveGenericsErrReason+ = -- | The type must not have some datatype context.+ DerivErrGenericsMustNotHaveDatatypeContext !TyCon+ -- | The data constructor must not have exotic unlifted+ -- or polymorphic arguments.+ | DerivErrGenericsMustNotHaveExoticArgs !DataCon+ -- | The data constructor must be a vanilla constructor.+ | DerivErrGenericsMustBeVanillaDataCon !DataCon+ -- | The type must have some type parameters.+ -- check (d) from Note [Requirements for deriving Generic and Rep]+ -- in GHC.Tc.Deriv.Generics.+ | DerivErrGenericsMustHaveSomeTypeParams !TyCon+ -- | The data constructor must not have existential arguments.+ | DerivErrGenericsMustNotHaveExistentials !DataCon+ -- | The derivation applies a type to an argument involving+ -- the last parameter but the applied type is not of kind * -> *.+ | DerivErrGenericsWrongArgKind !DataCon++data HasWildcard+ = YesHasWildcard+ | NoHasWildcard+ deriving Eq++hasWildcard :: Bool -> HasWildcard+hasWildcard True = YesHasWildcard+hasWildcard False = NoHasWildcard++-- | A type representing whether or not the input type has associated data family instances.+data HasAssociatedDataFamInsts+ = YesHasAdfs+ | NoHasAdfs+ deriving Eq++hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts+hasAssociatedDataFamInsts True = YesHasAdfs+hasAssociatedDataFamInsts False = NoHasAdfs++-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass+-- contains the last type variable of the class in a kind, which is not (yet) allowed+-- by GHC.+data AssociatedTyLastVarInKind+ = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class+ | NoAssocTyLastVarInKind+ deriving Eq++associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind+associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc+associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind++-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a+-- typeclass is not parameterized over the last type variable of the class+data AssociatedTyNotParamOverLastTyVar+ = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class+ | NoAssociatedTyNotParamOverLastTyVar+ deriving Eq++associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar+associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc+associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar
compiler/GHC/Tc/Solver/InertSet.hs view
@@ -41,6 +41,7 @@ import GHC.Types.Var import GHC.Types.Var.Env +import GHC.Core.Class (Class(..)) import GHC.Core.Reduction import GHC.Core.Predicate import GHC.Core.TyCo.FVs@@ -1235,7 +1236,10 @@ ics { inert_irreds = irreds `snocBag` item } addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })- = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }+ = ics { inert_dicts = addDictCt (inert_dicts ics) (classTyCon cls) tys item }++addInertItem _ ics@( IC { inert_irreds = irreds }) item@(CSpecialCan {})+ = ics { inert_irreds = irreds `snocBag` item } addInertItem _ _ item = pprPanic "upd_inert set: can't happen! Inserting " $
compiler/GHC/Tc/Solver/Types.hs view
@@ -15,7 +15,9 @@ FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq, findFunEqsByTyCon, - TcAppMap, isEmptyTcAppMap, insertTcApp, alterTcApp, filterTcAppMap,+ TcAppMap, emptyTcAppMap, isEmptyTcAppMap,+ insertTcApp, alterTcApp, filterTcAppMap,+ tcAppMapToBag, foldTcAppMap, EqualCtList, pattern EqualCtList, equalCtListToList, filterEqualCtList, unitEqualCtList,@@ -155,10 +157,10 @@ addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a addDict m cls tys item = insertTcApp m (classTyCon cls) tys item -addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct+addDictCt :: DictMap Ct -> TyCon -> [Type] -> Ct -> DictMap Ct -- Like addDict, but combines [W] and [D] to [WD] -- See Note [KeepBoth] in GHC.Tc.Solver.Interact-addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct+addDictCt m tc tys new_ct = alterTcApp m tc tys xt_ct where new_ct_ev = ctEvidence new_ct
compiler/GHC/Tc/Types.hs view
@@ -82,6 +82,10 @@ TcPluginSolver, TcPluginRewriter, TcPluginM(runTcPluginM), unsafeTcPluginTcM, + -- Defaulting plugin+ DefaultingPlugin(..), DefaultingProposal(..),+ FillDefaulting, DefaultingPluginResult,+ -- Role annotations RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot, getRoleAnnots,@@ -313,7 +317,7 @@ -- We need the module name so we can test when it's appropriate -- to look in this env. -- See Note [Tying the knot] in GHC.IfaceToCore- if_rec_types :: !(KnotVars (IfG TypeEnv))+ if_rec_types :: (KnotVars (IfG TypeEnv)) -- Allows a read effect, so it can be in a mutable -- variable; c.f. handling the external package type env -- Nothing => interactive stuff, no loops possible@@ -621,6 +625,9 @@ -- ^ A collection of all the user-defined type-checking plugins for rewriting -- type family applications, collated by their type family 'TyCon's. + tcg_defaulting_plugins :: [FillDefaulting],+ -- ^ A list of user-defined plugins for type defaulting plugins.+ tcg_hf_plugins :: [HoleFitPlugin], -- ^ A list of user-defined plugins for hole fit suggestions. @@ -1766,6 +1773,36 @@ { tcPluginReduction :: !Reduction , tcRewriterNewWanteds :: [Ct] }++-- | A collection of candidate default types for a type variable.+data DefaultingProposal+ = DefaultingProposal+ { deProposalTyVar :: TcTyVar+ -- ^ The type variable to default.+ , deProposalCandidates :: [Type]+ -- ^ Candidate types to default the type variable to.+ , deProposalCts :: [Ct]+ -- ^ The constraints against which defaults are checked.+ }++instance Outputable DefaultingProposal where+ ppr p = text "DefaultingProposal"+ <+> ppr (deProposalTyVar p)+ <+> ppr (deProposalCandidates p)+ <+> ppr (deProposalCts p)++type DefaultingPluginResult = [DefaultingProposal]+type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult++-- | A plugin for controlling defaulting.+data DefaultingPlugin = forall s. DefaultingPlugin+ { dePluginInit :: TcPluginM s+ -- ^ Initialize plugin, when entering type-checker.+ , dePluginRun :: s -> FillDefaulting+ -- ^ Default some types+ , dePluginStop :: s -> TcPluginM ()+ -- ^ Clean up after the plugin, when exiting the type-checker.+ } {- ********************************************************************* * *
compiler/GHC/Tc/Types/Constraint.hs view
@@ -239,6 +239,19 @@ -- look like this, with the payload in an -- auxiliary type + -- | A special canonical constraint.+ --+ -- When the 'SpecialPred' is 'ConcretePrimPred':+ --+ -- - `cc_ev` is Wanted,+ -- - `cc_xi = ty`, where `ty` cannot be decomposed any further.+ -- See Note [Canonical Concrete# constraints] in GHC.Tc.Solver.Canonical.+ | CSpecialCan {+ cc_ev :: CtEvidence,+ cc_special_pred :: SpecialPred,+ cc_xi :: Xi+ }+ ------------ -- | A 'CanEqLHS' is a type that can appear on the left of a canonical -- equality: a type variable or exactly-saturated type family application.@@ -612,6 +625,8 @@ CQuantCan (QCI { qci_pend_sc = pend_sc }) | pend_sc -> text "CQuantCan(psc)" | otherwise -> text "CQuantCan"+ CSpecialCan { cc_special_pred = special_pred } ->+ text "CSpecialCan" <> parens (ppr special_pred) ----------------------------------- -- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated
compiler/GHC/Tc/Types/Evidence.hs view
@@ -9,7 +9,7 @@ HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,- mkWpFun, idHsWrapper, isIdHsWrapper,+ idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, -- * Evidence bindings@@ -225,7 +225,7 @@ -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) - | WpFun HsWrapper HsWrapper (Scaled TcType) SDoc+ | WpFun HsWrapper HsWrapper (Scaled TcType) -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ] -- So note that if wrap1 :: exp_arg <= act_arg -- wrap2 :: act_res <= exp_res@@ -233,9 +233,8 @@ -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers -- The TcType is the "from" type of the first wrapper- -- The SDoc explains the circumstances under which we have created this- -- WpFun, in case we run afoul of representation polymorphism restrictions in- -- the desugarer. See Note [Representation polymorphism checking] in GHC.HsToCore.Monad+ --+ -- Use 'mkWpFun' to construct such a wrapper. | WpCast TcCoercionR -- A cast: [] `cast` co -- Guaranteed not the identity coercion@@ -256,45 +255,7 @@ | WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise, -- error in the desugarer. See GHC.Tc.Utils.Unify -- Note [Wrapper returned from tcSubMult]---- Cannot derive Data instance because SDoc is not Data (it stores a function).--- So we do it manually:-instance Data.Data HsWrapper where- gfoldl _ z WpHole = z WpHole- gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2- gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3- gfoldl k z (WpCast a1) = z WpCast `k` a1- gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1- gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1- gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1- gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1- gfoldl k z (WpLet a1) = z WpLet `k` a1- gfoldl k z (WpMultCoercion a1) = z WpMultCoercion `k` a1-- gunfold k z c = case Data.constrIndex c of- 1 -> z WpHole- 2 -> k (k (z WpCompose))- 3 -> k (k (k (z wpFunEmpty)))- 4 -> k (z WpCast)- 5 -> k (z WpEvLam)- 6 -> k (z WpEvApp)- 7 -> k (z WpTyLam)- 8 -> k (z WpTyApp)- 9 -> k (z WpLet)- _ -> k (z WpMultCoercion)-- toConstr WpHole = wpHole_constr- toConstr (WpCompose _ _) = wpCompose_constr- toConstr (WpFun _ _ _ _) = wpFun_constr- toConstr (WpCast _) = wpCast_constr- toConstr (WpEvLam _) = wpEvLam_constr- toConstr (WpEvApp _) = wpEvApp_constr- toConstr (WpTyLam _) = wpTyLam_constr- toConstr (WpTyApp _) = wpTyApp_constr- toConstr (WpLet _) = wpLet_constr- toConstr (WpMultCoercion _) = wpMultCoercion_constr-- dataTypeOf _ = hsWrapper_dataType+ deriving Data.Data -- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data -- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@,@@ -315,50 +276,11 @@ instance Monoid HsWrapper where mempty = WpHole -hsWrapper_dataType :: Data.DataType-hsWrapper_dataType- = Data.mkDataType "HsWrapper"- [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr- , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr- , wpLet_constr, wpMultCoercion_constr ]--wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr,- wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr,- wpMultCoercion_constr :: Data.Constr-wpHole_constr = mkHsWrapperConstr "WpHole"-wpCompose_constr = mkHsWrapperConstr "WpCompose"-wpFun_constr = mkHsWrapperConstr "WpFun"-wpCast_constr = mkHsWrapperConstr "WpCast"-wpEvLam_constr = mkHsWrapperConstr "WpEvLam"-wpEvApp_constr = mkHsWrapperConstr "WpEvApp"-wpTyLam_constr = mkHsWrapperConstr "WpTyLam"-wpTyApp_constr = mkHsWrapperConstr "WpTyApp"-wpLet_constr = mkHsWrapperConstr "WpLet"-wpMultCoercion_constr = mkHsWrapperConstr "WpMultCoercion"--mkHsWrapperConstr :: String -> Data.Constr-mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix--wpFunEmpty :: HsWrapper -> HsWrapper -> Scaled TcType -> HsWrapper-wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty- (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c c <.> WpHole = c c1 <.> c2 = c1 `WpCompose` c2 -mkWpFun :: HsWrapper -> HsWrapper- -> (Scaled TcType) -- the "from" type of the first wrapper- -> TcType -- either type of the second wrapper (used only when the- -- second wrapper is the identity)- -> SDoc -- what caused you to want a WpFun? Something like "When converting ..."- -> HsWrapper-mkWpFun WpHole WpHole _ _ _ = WpHole-mkWpFun WpHole (WpCast co2) (Scaled w t1) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2)-mkWpFun (WpCast co1) WpHole (Scaled w _) t2 _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2))-mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2)-mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d- mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co | isTcReflCo co = WpHole@@ -420,7 +342,7 @@ where go (WpEvLam dict_id) = unitBag dict_id go (w1 `WpCompose` w2) = go w1 `unionBags` go w2- go (WpFun _ w _ _) = go w+ go (WpFun _ w _) = go w go WpHole = emptyBag go (WpCast {}) = emptyBag go (WpEvApp {}) = emptyBag@@ -1033,8 +955,8 @@ -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1- help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>- help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False+ help it (WpFun f1 f2 (Scaled w t1)) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>+ help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
compiler/GHC/Tc/Types/Origin.hs view
@@ -21,8 +21,16 @@ pprCtOrigin, isGivenOrigin, -- CtOrigin and CallStack- isPushCallStackOrigin, callStackOriginFS+ isPushCallStackOrigin, callStackOriginFS,+ -- FixedRuntimeRep origin+ FRROrigin(..), pprFRROrigin,+ StmtOrigin(..), + -- Arrow command origin+ FRRArrowOrigin(..), pprFRRArrowOrigin,+ -- HsWrapper WpFun origin+ WpFunOrigin(..), pprWpFunOrigin,+ ) where import GHC.Prelude@@ -226,8 +234,6 @@ -- The pattern MkT x will allocate an existential type -- variable for 'a'. - | ArrowSkol -- An arrow form (see GHC.Tc.Gen.Arrow)- | IPSkol [HsIPName] -- Binding site of an implicit parameter | RuleSkol RuleName -- The LHS of a RULE@@ -272,7 +278,6 @@ pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name-pprSkolInfo ArrowSkol = text "an arrow form" pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of")@@ -437,6 +442,7 @@ | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a -- monad comprehension | ProcOrigin -- Arising from a proc expression+ | ArrowCmdOrigin -- Arising from an arrow command | AnnOrigin -- An annotation | FunDepOrigin1 -- A functional dependency from combining@@ -460,15 +466,25 @@ -- the user should never see this one, -- unless ImpredicativeTypes is on, where all -- bets are off- | InstProvidedOrigin Module ClsInst- -- Skolem variable arose when we were testing if an instance- -- is solvable or not.++ -- | Testing whether the constraint associated with an instance declaration+ -- in a signature file is satisfied upon instantiation.+ --+ -- Test cases: backpack/should_fail/bkpfail{11,43}.bkp+ | InstProvidedOrigin+ Module -- ^ Module in which the instance was declared+ ClsInst -- ^ The declared typeclass instance+ | NonLinearPatternOrigin | UsageEnvironmentOf Name | CycleBreakerOrigin CtOrigin -- origin of the original constraint -- See Detail (7) of Note [Type variable cycles] in GHC.Tc.Solver.Canonical+ | FixedRuntimeRepOrigin+ !Type -- ^ The type being checked for representation polymorphism.+ -- We record it here for access in 'GHC.Tc.Errors.mkFRRErr'.+ !FRROrigin -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible@@ -637,6 +653,12 @@ pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig +pprCtOrigin (FixedRuntimeRepOrigin _ frrOrig)+ -- We ignore the type argument, as we would prefer+ -- to report all types that don't have a fixed runtime representation at once,+ -- in 'GHC.Tc.Errors.mkFRRErr'.+ = pprFRROrigin frrOrig+ pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin @@ -668,6 +690,7 @@ pprCtO DoOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression"+pprCtO ArrowCmdOrigin = text "an arrow command" pprCtO AnnOrigin = text "an annotation" pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ)@@ -696,6 +719,7 @@ pprCtO (ProvCtxtOrigin {}) = text "a provided constraint" pprCtO (InstProvidedOrigin {}) = text "a provided constraint" pprCtO (CycleBreakerOrigin orig) = pprCtO orig+pprCtO (FixedRuntimeRepOrigin {}) = text "a representation polymorphism check" {- ********************************************************************* * *@@ -717,3 +741,317 @@ -- This is the string that appears in the CallStack callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun) callStackOriginFS orig = mkFastString (showSDocUnsafe (pprCtO orig))++{-+************************************************************************+* *+ Checking for representation polymorphism+* *+************************************************************************++Note [Reporting representation-polymorphism errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we emit a 'Concrete#' Wanted constraint using GHC.Tc.Utils.Concrete.hasFixedRuntimeRep,+we provide a 'CtOrigin' using the 'FixedRuntimeRepOrigin' constructor of,+which keeps track of two things:+ - the type which we want to ensure has a fixed runtime representation,+ - the 'FRROrigin' explaining the nature of the check, e.g. a pattern,+ a function application, a record update, ...++If the constraint goes unsolved, we report it as follows:+ - we detect that the unsolved Wanted is a Concrete# constraint in+ GHC.Tc.Errors.reportWanteds using is_FRR,+ - we assemble an error message in GHC.Tc.Errors.mkFRRErr.++For example, if we try to write the program++ foo :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> ()+ foo x y = ()++we will get two unsolved Concrete# wanted constraints, namely+'Concrete# r1' and 'Concrete# r2', and their 'CtOrigin's will be:++ FixedRuntimeRepOrigin a (FRRVarPattern x)+ FixedRuntimeRepOrigin b (FRRVarPattern y)++These constraints will be processed in tandem by mkFRRErr,+producing an error message of the form:++ Representation-polymorphic types are not allowed here.+ * The variable 'x' bound by the pattern+ does not have a fixed runtime representation:+ a :: TYPE r1+ * The variable 'y' bound by the pattern+ does not have a fixed runtime representation:+ b :: TYPE r2+-}++-- | Where are we checking that a type has a fixed runtime representation?+-- Equivalently: what is the origin of an emitted 'Concrete#' constraint?+data FRROrigin++ -- | Function arguments must have a fixed runtime representation.+ --+ -- Test case: RepPolyApp.+ = FRRApp !(HsExpr GhcRn)++ -- | Record fields in record updates must have a fixed runtime representation.+ --+ -- Test case: RepPolyRecordUpdate.+ | FRRRecordUpdate !RdrName !(HsExpr GhcRn)++ -- | Variable binders must have a fixed runtime representation.+ --+ -- Test cases: LevPolyLet, RepPolyPatBind.+ | FRRBinder !Name++ -- | The type of a pattern in a match group must have a fixed runtime representation.+ --+ -- This rules out:+ -- - individual patterns which don't have a fixed runtime representation,+ -- - a representation-polymorphic empty case statement,+ -- - representation-polymorphic GADT pattern matches+ -- in which individual pattern types have a fixed runtime representation.+ --+ -- Test cases: RepPolyRecordPattern, RepPolyUnboxedPatterns,+ -- RepPolyBinder, RepPolyWildcardPattern, RepPolyMatch,+ -- RepPolyNPlusK, RepPolyPatBind, T20426.+ | FRRMatch !(HsMatchContext GhcTc) !Int++ -- | An instantiation of a newtype/data constructor in which+ -- one of the remaining arguments types does not have a fixed runtime representation.+ --+ -- Test case: UnliftedNewtypesLevityBinder.+ | FRRDataConArg !DataCon !Int++ -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`)+ -- in which one of the remaining arguments types does not have a fixed runtime representation.+ --+ -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesCoerceFail.+ | FRRNoBindingResArg !Id !Int++ -- | Arguments to unboxed tuples must have fixed runtime representations.+ --+ -- Test case: RepPolyTuple.+ | FRRTupleArg !Int++ -- | Tuple sections must have a fixed runtime representation.+ --+ -- Test case: RepPolyTupleSection.+ | FRRTupleSection !Int++ -- | Unboxed sums must have a fixed runtime representation.+ --+ -- Test cases: RepPolySum.+ | FRRUnboxedSum++ -- | The body of a @do@ expression or a monad comprehension must+ -- have a fixed runtime representation.+ --+ -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody.+ | FRRBodyStmt !StmtOrigin !Int++ -- | Arguments to a guard in a monad comprehesion must have+ -- a fixed runtime representation.+ --+ -- Test case: RepPolyMcGuard.+ | FRRBodyStmtGuard++ -- | Arguments to `(>>=)` arising from a @do@ expression+ -- or a monad comprehension must have a fixed runtime representation.+ --+ -- Test cases: RepPolyDoBind, RepPolyMcBind.+ | FRRBindStmt !StmtOrigin++ -- | A value bound by a pattern guard must have a fixed runtime representation.+ --+ -- Test cases: none.+ | FRRBindStmtGuard++ -- | A representation-polymorphism check arising from arrow notation.+ --+ -- See 'FRRArrowOrigin' for more details.+ | FRRArrow !FRRArrowOrigin++ -- | A representation-polymorphic check arising from an 'HsWrapper'.+ --+ -- See 'WpFunOrigin' for more details.+ | FRRWpFun !WpFunOrigin++-- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check.+--+-- Note that this function does not include the specific 'RuntimeRep'+-- which is not fixed. That information is added by 'GHC.Tc.Errors.mkFRRErr'.+pprFRROrigin :: FRROrigin -> SDoc+pprFRROrigin (FRRApp arg)+ = sep [ text "The function argument"+ , nest 2 $ quotes (ppr arg)+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRRecordUpdate lbl _arg)+ = hsep [ text "The record update at field"+ , quotes (ppr lbl)+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRBinder binder)+ = hsep [ text "The binder"+ , quotes (ppr binder)+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRMatch matchCtxt i)+ = vcat [ text "The type of the" <+> speakNth i <+> text "pattern in the" <+> pprMatchContextNoun matchCtxt+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRDataConArg con i)+ = sep [ text "The" <+> what+ , text "does not have a fixed runtime representation"]+ where+ what :: SDoc+ what+ | isNewDataCon con+ = text "newtype constructor argument"+ | otherwise+ = text "data constructor argument in" <+> speakNth i <+> text "position"+pprFRROrigin (FRRNoBindingResArg fn i)+ = vcat [ text "Unsaturated use of a representation-polymorphic primitive function."+ , text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn)+ , text "does not have a fixed runtime representation" ]+pprFRROrigin (FRRTupleArg i)+ = hsep [ text "The tuple argument in" <+> speakNth i <+> text "position"+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRTupleSection i)+ = hsep [ text "The tuple section does not have a fixed runtime representation"+ , text "in the" <+> speakNth i <+> text "position" ]+pprFRROrigin FRRUnboxedSum+ = hsep [ text "The unboxed sum result type"+ , text "does not have a fixed runtime representation"]+pprFRROrigin (FRRBodyStmt stmtOrig i)+ = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma+ , text "arising from the" <+> ppr stmtOrig <> comma+ , text "does not have a fixed runtime representation" ]+pprFRROrigin FRRBodyStmtGuard+ = vcat [ text "The argument to" <+> quotes (text "guard") <> comma+ , text "arising from the" <+> ppr MonadComprehension <> comma+ , text "does not have a fixed runtime representation" ]+pprFRROrigin (FRRBindStmt stmtOrig)+ = vcat [ text "The first argument to (>>=)" <> comma+ , text "arising from the" <+> ppr stmtOrig <> comma+ , text "does not have a fixed runtime representation" ]+pprFRROrigin FRRBindStmtGuard+ = hsep [ text "The return type of the bind statement"+ , text "does not have a fixed runtime representation" ]+pprFRROrigin (FRRArrow arrowOrig)+ = pprFRRArrowOrigin arrowOrig+pprFRROrigin (FRRWpFun wpFunOrig)+ = pprWpFunOrigin wpFunOrig++instance Outputable FRROrigin where+ ppr = pprFRROrigin++-- | Are we in a @do@ expression or a monad comprehension?+--+-- This datatype is only used to report this context to the user in error messages.+data StmtOrigin+ = MonadComprehension+ | DoNotation++instance Outputable StmtOrigin where+ ppr MonadComprehension = text "monad comprehension"+ ppr DoNotation = quotes ( text "do" ) <+> text "statement"++{- *********************************************************************+* *+ FixedRuntimeRep: arrows+* *+********************************************************************* -}++-- | While typechecking arrow notation, in which context+-- did a representation polymorphism check arise?+--+-- See 'FRROrigin' for more general origins of representation polymorphism checks.+data FRRArrowOrigin++ -- | The result of an arrow command does not have a fixed runtime representation.+ --+ -- Test case: RepPolyArrowCmd.+ = ArrowCmdResTy !(HsCmd GhcRn)++ -- | The argument to an arrow in an arrow command application does not have+ -- a fixed runtime representation.+ --+ -- Test cases: none.+ | ArrowCmdApp !(HsCmd GhcRn) !(HsExpr GhcRn)++ -- | A function in an arrow application does not have+ -- a fixed runtime representation.+ --+ -- Test cases: none.+ | ArrowCmdArrApp !(HsExpr GhcRn) !(HsExpr GhcRn) !HsArrAppType++ -- | A pattern in an arrow command abstraction does not have+ -- a fixed runtime representation.+ --+ -- Test cases: none.+ | ArrowCmdLam !Int++ -- | The overall type of an arrow proc expression does not have+ -- a fixed runtime representation.+ --+ -- Test case: RepPolyArrowFun.+ | ArrowFun !(HsExpr GhcRn)++pprFRRArrowOrigin :: FRRArrowOrigin -> SDoc+pprFRRArrowOrigin (ArrowCmdResTy cmd)+ = vcat [ hang (text "The arrow command") 2 (quotes (ppr cmd))+ , text "does not have a fixed runtime representation" ]+pprFRRArrowOrigin (ArrowCmdApp fun arg)+ = vcat [ text "In the arrow command application of"+ , nest 2 (quotes (ppr fun))+ , text "to"+ , nest 2 (quotes (ppr arg)) <> comma+ , text "the argument does not have a fixed runtime representation" ]+pprFRRArrowOrigin (ArrowCmdArrApp fun arg ho_app)+ = vcat [ text "In the" <+> pprHsArrType ho_app <+> text "of"+ , nest 2 (quotes (ppr fun))+ , text "to"+ , nest 2 (quotes (ppr arg)) <> comma+ , text "the function does not have a fixed runtime representation" ]+pprFRRArrowOrigin (ArrowCmdLam i)+ = vcat [ text "The" <+> speakNth i <+> text "pattern of the arrow command abstraction"+ , text "does not have a fixed runtime representation" ]+pprFRRArrowOrigin (ArrowFun fun)+ = vcat [ text "The return type of the arrow function"+ , nest 2 (quotes (ppr fun))+ , text "does not have a fixed runtime representation" ]++instance Outputable FRRArrowOrigin where+ ppr = pprFRRArrowOrigin++{- *********************************************************************+* *+ FixedRuntimeRep: HsWrapper WpFun origin+* *+********************************************************************* -}++-- | While typechecking a 'WpFun' 'HsWrapper', in which context+-- did a representation polymorphism check arise?+--+-- See 'FRROrigin' for more general origins of representation polymorphism checks.+data WpFunOrigin+ = WpFunSyntaxOp !CtOrigin+ | WpFunViewPat !(HsExpr GhcRn)+ | WpFunFunTy !Type+ | WpFunFunExpTy !ExpType++pprWpFunOrigin :: WpFunOrigin -> SDoc+pprWpFunOrigin (WpFunSyntaxOp orig)+ = vcat [ text "When checking a rebindable syntax operator arising from"+ , nest 2 (ppr orig) ]+pprWpFunOrigin (WpFunViewPat expr)+ = vcat [ text "When checking the view pattern function:"+ , nest 2 (ppr expr) ]+pprWpFunOrigin (WpFunFunTy fun_ty)+ = vcat [ text "When inferring the argument type of a function with type"+ , nest 2 (ppr fun_ty) ]+pprWpFunOrigin (WpFunFunExpTy fun_ty)+ = vcat [ text "When inferring the argument type of a function with expected type"+ , nest 2 (ppr fun_ty) ]++instance Outputable WpFunOrigin where+ ppr = pprWpFunOrigin
compiler/GHC/Tc/Utils/TcType.hs view
@@ -146,7 +146,7 @@ isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass, mkClassPred, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,- isRuntimeRepVar, isKindLevPoly,+ isRuntimeRepVar, isFixedRuntimeRepKind, isVisibleBinder, isInvisibleBinder, -- Type substitutions@@ -228,7 +228,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Utils.Error( Validity(..), isValid )+import GHC.Utils.Error( Validity'(..), Validity, isValid ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL )@@ -1935,6 +1935,7 @@ ClassPred cls _ -> classHasFds cls IrredPred {} -> True -- Might have equalities after reduction? ForAllPred {} -> False+ SpecialPred {} -> False {- Note [Expanding superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Utils/TcType.hs-boot view
@@ -2,6 +2,8 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )+import {-# SOURCE #-} GHC.Core.TyCo.Rep+import GHC.Utils.Misc ( HasDebugCallStack ) data MetaDetails @@ -10,3 +12,5 @@ vanillaSkolemTv :: TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool++tcEqType :: HasDebugCallStack => Type -> Type -> Bool
compiler/GHC/Types/Basic.hs view
@@ -101,6 +101,9 @@ TypeOrKind(..), isTypeLevel, isKindLevel, + DefaultKindVars(..), DefaultVarsOfKind(..),+ allVarsOfKindDefault, noVarsOfKindDefault,+ ForeignSrcLang (..) ) where @@ -503,6 +506,12 @@ ppr Boxed = text "Boxed" ppr Unboxed = text "Unboxed" +instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool+ put_ bh = put_ bh . isBoxed+ get bh = do+ b <- get bh+ pure $ if b then Boxed else Unboxed+ {- ************************************************************************ * *@@ -1739,3 +1748,60 @@ isKindLevel :: TypeOrKind -> Bool isKindLevel TypeLevel = False isKindLevel KindLevel = True++{- *********************************************************************+* *+ Defaulting options+* *+********************************************************************* -}++-- | Whether to default kind variables. Usually: no, unless `-XNoPolyKinds`+-- is enabled.+data DefaultKindVars+ = Don'tDefaultKinds+ | DefaultKinds++instance Outputable DefaultKindVars where+ ppr Don'tDefaultKinds = text "Don'tDefaultKinds"+ ppr DefaultKinds = text "DefaultKinds"++-- | Whether to default type variables of the given kinds:+--+-- - default 'RuntimeRep' variables to LiftedRep?+-- - default 'Levity' variables to Lifted?+-- - default 'Multiplicity' variables to Many?+data DefaultVarsOfKind =+ DefaultVarsOfKind+ { def_runtimeRep, def_levity, def_multiplicity :: !Bool }++instance Outputable DefaultVarsOfKind where+ ppr+ (DefaultVarsOfKind+ { def_runtimeRep = rep+ , def_levity = lev+ , def_multiplicity = mult })+ = text "DefaultVarsOfKind:" <+> defaults+ where+ defaults :: SDoc+ defaults =+ case filter snd $ [ ("RuntimeRep", rep), ("Levity", lev), ("Multiplicity", mult)] of+ [] -> text "<no defaulting>"+ defs -> hsep (map (text . fst) defs)++-- | Do defaulting for variables of kind `RuntimeRep`, `Levity` and `Multiplicity`.+allVarsOfKindDefault :: DefaultVarsOfKind+allVarsOfKindDefault =+ DefaultVarsOfKind+ { def_runtimeRep = True+ , def_levity = True+ , def_multiplicity = True+ }++-- | Don't do defaulting for variables of kind `RuntimeRep`, `Levity` and `Multiplicity`.+noVarsOfKindDefault :: DefaultVarsOfKind+noVarsOfKindDefault =+ DefaultVarsOfKind+ { def_runtimeRep = False+ , def_levity = False+ , def_multiplicity = False+ }
+ compiler/GHC/Types/BreakInfo.hs view
@@ -0,0 +1,12 @@+-- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and+-- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module+-- dependency tree+module GHC.Types.BreakInfo (BreakInfo(..)) where++import GHC.Prelude+import GHC.Unit.Module++data BreakInfo = BreakInfo+ { breakInfo_module :: Module+ , breakInfo_number :: Int+ }
compiler/GHC/Types/Demand.hs view
@@ -16,9 +16,10 @@ -- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". module GHC.Types.Demand ( -- * Demands+ Boxity(..), Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce, Demand(AbsDmd, BotDmd, (:*)),- SubDemand(Prod), mkProd, viewProd,+ SubDemand(Prod, Poly), mkProd, viewProd, unboxSubDemand, -- ** Algebra absDmd, topDmd, botDmd, seqDmd, topSubDmd, -- *** Least upper bound@@ -30,7 +31,7 @@ -- ** Predicates on @Card@inalities and @Demand@s isAbs, isUsedOnce, isStrict, isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,- isTopDmd, isSeqDmd, isWeakDmd,+ isTopDmd, isWeakDmd, -- ** Special demands evalDmd, -- *** Demands used in PrimOp signatures@@ -38,7 +39,6 @@ -- ** Other @Demand@ operations oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,- addCaseBndrDmd, -- ** Extracting one-shot information argOneShots, argsOneShots, saturatedByOneShots, @@ -71,7 +71,7 @@ DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, -- * Trim to a type shape- TypeShape(..), trimToType,+ TypeShape(..), trimToType, trimBoxity, -- * @seq@ing stuff seqDemand, seqDemandList, seqDmdType, seqDmdSig,@@ -108,6 +108,260 @@ {- ************************************************************************ * *+ Boxity: Whether the box of something is used+* *+************************************************************************+-}++{- Note [Strictness and Unboxing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an argument is used strictly by the function body, we may use use+call-by-value instead of call-by-need for that argument. What's more, we may+unbox an argument that is used strictly, discarding the box at the call site.+This can reduce allocations of the program drastically if the box really isn't+needed in the function body. Here's an example:+```+even :: Int -> Bool+even (I# 0) = True+even (I# 1) = False+even (I# n) = even (I# (n -# 2))+```+All three code paths of 'even' are (a) strict in the argument, and (b)+immediately discard the boxed 'Int'. Now if we have a call site like+`even (I# 42)`, then it would be terrible to allocate the 'I#' box for the+argument only to tear it apart immediately in the body of 'even'! Hence,+worker/wrapper will allocate a wrapper for 'even' that not only uses+call-by-value for the argument (e.g., `case I# 42 of b { $weven b }`), but also+*unboxes* the argument, resulting in+```+even :: Int -> Bool+even (I# n) = $weven n+$weven :: Int# -> Bool+$weven 0 = True+$weven 1 = False+$weven n = $weven (n -# 2)+```+And now the box in `even (I# 42)` will cancel away after inlining the wrapper.++As far as the permission to unbox is concerned, *evaluatedness* of the argument+is the important trait. Unboxing implies eager evaluation of an argument and+we don't want to change the termination properties of the function. One way+to ensure that is to unbox strict arguments only, but strictness is only a+sufficient condition for evaluatedness.+See Note [Unboxing evaluated arguments] in "GHC.Core.Opt.WorkWrap.Utils", where+we manage to unbox *strict fields* of unboxed arguments that the function is not+actually strict in, simply by realising that those fields have to be evaluated.++Note [Boxity analysis]+~~~~~~~~~~~~~~~~~~~~~~+Alas, we don't want to unbox *every* strict argument+(as Note [Strictness and Unboxing] might suggest).+Here's an example (from T19871):+```+data Huge = H Bool Bool ... Bool+ann :: Huge -> (Bool, Huge)+ann h@(Huge True _ ... _) = (False, h)+ann h = (True, h)+```+Unboxing 'h' yields+```+$wann :: Bool -> Bool -> ... -> Bool -> (Bool, Huge)+$wann True b2 ... bn = (False, Huge True b2 ... bn)+$wann b1 b2 ... bn = (True, Huge b1 b2 ... bn)+```+The pair constructor really needs its fields boxed. But '$wann' doesn't get+passed 'h' anymore, only its components! Ergo it has to reallocate the 'Huge'+box, in a process called "reboxing". After w/w, call sites like+`case ... of Just h -> ann h` pay for the allocation of the additional box.+In earlier versions of GHC we simply accepted that reboxing would sometimes+happen, but we found some cases where it made a big difference: #19407, for+example.++We therefore perform a simple syntactic boxity analysis that piggy-backs on+demand analysis in order to determine whether the box of a strict argument is+always discarded in the function body, in which case we can pass it unboxed+without risking regressions such as in 'ann' above. But as soon as one use needs+the box, we want Boxed to win over any Unboxed uses.+(We don't adhere to that in 'lubBoxity', see Note [lubBoxity and plusBoxity].)++The demand signature (cf. Note [Demand notation]) will say whether it uses+its arguments boxed or unboxed. Indeed it does so for every sub-component of+the argument demand. Here's an example:+```+f :: (Int, Int) -> Bool+f (a, b) = even (a + b) -- demand signature: <1!P(1!L,1!L)>+```+The '!' indicates places where we want to unbox, the lack thereof indicates the+box is used by the function. Boxity flags are part of the 'Poly' and 'Prod'+'SubDemand's, see Note [Why Boxity in SubDemand and not in Demand?].+The given demand signature says "Unbox the pair and then nestedly unbox its+two fields". By contrast, the demand signature of 'ann' above would look like+<1P(1L,L,...,L)>, lacking any '!'.++A demand signature like <1P(1!L)> -- Boxed outside but Unboxed in the field --+doesn't make a lot of sense, as we can never unbox the field without unboxing+the containing record. See Note [Finalising boxity for demand signature] in+"GHC.Core.Opt.WorkWrap.Utils" for how we avoid to spread this and other kinds of+misinformed boxities.++Due to various practical reasons, Boxity Analysis is not conservative at times.+Here are reasons for too much optimism:++ * Note [Function body boxity and call sites] is an observation about when it is+ beneficial to unbox a parameter that is returned from a function.+ Note [Unboxed demand on function bodies returning small products] derives+ a heuristic from the former Note, pretending that all call sites of a+ function need returned small products Unboxed.+ * Note [lubBoxity and plusBoxity] describes why we optimistically let Unboxed+ win when combining different case alternatives.++Boxity analysis fixes a number of issues:+#19871, #19407, #4267, #16859, #18907, #13331++Note [Function body boxity and call sites]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (from T5949)+```+f n p = case n of+ 0 -> p :: (a, b)+ _ -> f (n-1) p+-- Worker/wrapper split if we decide to unbox:+$wf n x y = case n of+ 0 -> (# x, y #)+ _ -> $wf (n-1) x y+f n (x,y) = case $wf n x y of (# r, s #) -> (r,s)+```+When is it better to /not/ to unbox 'p'? That depends on the callers of 'f'!+If all call sites++ 1. Wouldn't need to allocate fresh boxes for 'p', and+ 2. Needed the result pair of 'f' boxed++Only then we'd see an increase in allocation resulting from unboxing. But as+soon as only one of (1) or (2) holds, it really doesn't matter if 'f' unboxes+'p' (and its result, it's important that CPR follows suit). For example+```+res = ... case f m (field t) of (r1,r2) -> ... -- (1) holds+arg = ... [ f m (x,y) ] ... -- (2) holds+```+Because one of the boxes in the call site can cancel away:+```+res = ... case field1 t of (x1,x2) ->+ case field2 t of (y1,y2) ->+ case $wf x1 x2 y1 y2 of (#r1,r2#) -> ...+arg = ... [ case $wf x1 x2 y1 y2 of (#r1,r2#) -> (r1,r2) ] ...+```+And when call sites neither have arg boxes (1) nor need the result boxed (2),+then hesitating to unbox means /more/ allocation in the call site because of the+need for fresh argument boxes.++Summary: If call sites that satisfy both (1) and (2) occur more often than call+sites that satisfy neither condition, then it's best /not/ to unbox 'p'.++Note [Unboxed demand on function bodies returning small products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Boxity analysis] achieves its biggest wins when we avoid reboxing huge+records. But when we return small products from a function, we often get faster+programs by pretending that the caller unboxes the result. Long version:++Observation: Big record arguments (e.g., DynFlags) tend to be modified much less+ frequently than small records (e.g., Int).+Result: Big records tend to be passed around boxed (unmodified) much more+ frequently than small records.+Consequnce: The larger the record, the more likely conditions (1) and (2) from+ Note [Function body boxity and call sites] are met, in which case+ unboxing returned parameters leads to reboxing.++So we put an Unboxed demand on function bodies returning small products and a+Boxed demand on the others. What is regarded a small product is controlled by+the -fdmd-unbox-width flag.++This also manages to unbox functions like+```+sum z [] = z+sum (I# n) ((I# x):xs) = sum (I# (n +# x)) xs+```+where we can unbox 'z' on the grounds that it's but a small box anyway. That in+turn means that the I# allocation in the recursive call site can cancel away and+we get a non-allocating loop, nice and tight.+Note that this is the typical case in "Observation" above: A small box is+unboxed, modified, the result reboxed for the recursive call.++Originally, this came up in binary-trees' check' function and #4267 which+(similarly) features a strict fold over a tree. We'd also regress in join004 and+join007 if we didn't assume an optimistic Unboxed demand on the function body.+T17932 features a (non-recursive) function that returns a large record, e.g.,+```+flags (Options f x) = <huge> `seq` f+```+and here we won't unbox 'f' because it has 5 fields (which is larger than the+default -fdmd-unbox-width threshold).++Why not focus on putting Unboxed demands on all recursive function?+Then we'd unbox+```+flags 0 (Options f x) = <huge> `seq` f+flags n o = flags (n-1) o+```+and that seems hardly useful.+(NB: Similar to 'f' from Note [Preserving Boxity of results is rarely a win],+but there we only had 2 fields.)++Note [lubBoxity and plusBoxity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should 'Boxed' win in 'lubBoxity' and 'plusBoxity'?+The first intuition is Yes, because that would be the conservative choice:+Responding 'Boxed' when there's the slightest chance we might need the box means+we'll never need to rebox a value.++For 'plusBoxity' the choice of 'boxedWins' is clear: When we need a value to be+Boxed and Unboxed /in the same trace/, then we clearly need it to be Boxed.++But if we chose 'boxedWins' for 'lubBoxity', we'd regress T3586. Smaller example+```+sumIO :: Int -> Int -> IO Int+sumIO 0 !z = return z+sumIO n !z = sumIO (n-1) (z+n)+```+We really want 'z' to unbox here. Yet its use in the returned unboxed pair+is fundamentally a Boxed one! CPR would manage to unbox it, but DmdAnal runs+before that. There is an Unboxed use in the recursive call to 'go' though.+So we choose 'unboxedWins' for 'lubBoxity' to collect this win.++Choosing 'unboxedWins' is not conservative. There clearly is ample room for+examples that get worse by our choice. Here's a simple one (from T19871):+```+data Huge = H { f1 :: Bool, ... many fields ... }+update :: Huge -> (Bool, Huge)+update h@(Huge{f1=True}) = (False, h{f1=False})+update h = (True, h)+```+Here, we decide to unbox 'h' because it's used Unboxed in the first branch.++Note that this is fundamentally working around a phase problem, namely that the+results of boxity analysis depend on CPR analysis (and vice versa, of course).+-}++boxedWins :: Boxity -> Boxity -> Boxity+boxedWins Unboxed Unboxed = Unboxed+boxedWins _ !_ = Boxed++unboxedWins :: Boxity -> Boxity -> Boxity+unboxedWins Boxed Boxed = Boxed+unboxedWins _ !_ = Unboxed++lubBoxity :: Boxity -> Boxity -> Boxity+-- See Note [Boxity analysis] for the lattice.+-- See Note [lubBoxity and plusBoxity].+lubBoxity = unboxedWins++plusBoxity :: Boxity -> Boxity -> Boxity+-- See Note [lubBoxity and plusBoxity].+plusBoxity = boxedWins++{-+************************************************************************+* * Card: Combining Strictness and Usage * * ************************************************************************@@ -406,20 +660,26 @@ -- -- See Note [Call demands are relative] -- and Note [Demand notation].+-- See also Note [Why Boxity in SubDemand and not in Demand?]. data SubDemand- = Poly !CardNonOnce+ = Poly !Boxity !CardNonOnce -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep,- -- with the specified cardinality at every level.+ -- with the specified cardinality at every level. The 'Boxity' applies only+ -- to the outer evaluation context; inner evaluation context can be regarded+ -- as 'Boxed'. See Note [Boxity in Poly] for why we want it to carry 'Boxity'. -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'. --- -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or- -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites.+ -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly Boxed n, ...]@+ -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites. --- -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@,- -- @B === P(B,B,...)@ and @B === CB(B)@, and so on.+ -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@,+ -- @B === P(B,B,...)@ and @B === CB(B)@,+ -- @!A === !P(A,A,...)@ and @!A === !CA(A)@,+ -- and so on. --- -- We only really use 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and- -- sometimes 'C_1N' (S), hence 'CardNonOnce'.+ -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes+ -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the+ -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'. | Call !CardNonAbs !SubDemand -- ^ @Call n sd@ describes the evaluation context of @n@ function -- applications, where every individual result is evaluated according to @sd@.@@ -429,53 +689,68 @@ -- expressed with 'Poly'. -- Used only for values of function type. Use the smart constructor 'mkCall' -- whenever possible!- | Prod ![Demand]- -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation+ | Prod !Boxity ![Demand]+ -- ^ @Prod b ds@ describes the evaluation context of a case scrutinisation -- on an expression of product type, where the product components are- -- evaluated according to @ds@.- deriving Eq+ -- evaluated according to @ds@. The 'Boxity' @b@ says whether or not the box+ -- of the product was used. -poly00, poly0N, poly1N, poly10 :: SubDemand+-- | We have to respect Poly rewrites through 'viewCall' and 'viewProd'.+instance Eq SubDemand where+ d1 == d2 = case d1 of+ Prod b1 ds1+ | Just (b2, ds2) <- viewProd (length ds1) d2 -> b1 == b2 && ds1 == ds2+ Call n1 sd1+ | Just (n2, sd2) <- viewCall d2 -> n1 == n2 && sd1 == sd2+ Poly b1 n1+ | Poly b2 n2 <- d2 -> b1 == b2 && n1 == n2+ _ -> False+ topSubDmd, botSubDmd, seqSubDmd :: SubDemand-poly00 = Poly C_00-poly0N = Poly C_0N-poly1N = Poly C_1N-poly10 = Poly C_10-topSubDmd = poly0N-botSubDmd = poly10-seqSubDmd = poly00+topSubDmd = Poly Boxed C_0N+botSubDmd = Poly Unboxed C_10+seqSubDmd = Poly Unboxed C_00 -polyDmd :: CardNonOnce -> Demand-polyDmd C_00 = AbsDmd-polyDmd C_10 = BotDmd-polyDmd C_0N = C_0N :* poly0N-polyDmd C_1N = C_1N :* poly1N-polyDmd c = pprPanic "non-once Card" (ppr c)+-- | The uniform field demand when viewing a 'Poly' as a 'Prod', as in+-- 'viewProd'.+polyFieldDmd :: CardNonOnce -> Demand+polyFieldDmd C_00 = AbsDmd+polyFieldDmd C_10 = BotDmd+polyFieldDmd C_0N = topDmd+polyFieldDmd n = C_1N :* Poly Boxed C_1N & assertPpr (isCardNonOnce n) (ppr n) -- | A smart constructor for 'Prod', applying rewrite rules along the semantic--- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'--- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a--- polymorphic demand will never unbox.-mkProd :: [Demand] -> SubDemand-mkProd [] = seqSubDmd--- We only want to simplify absent and bottom demands and unbox the others.--- See also Note [L should win] and Note [Don't optimise LP(L,L,...) to L].-mkProd ds- | all (== AbsDmd) ds = seqSubDmd- | all (== BotDmd) ds = botSubDmd- | otherwise = Prod ds+-- equality @Prod b [n :* Poly Boxed n, ...] === Poly b n@, simplifying to+-- 'Poly' 'SubDemand's when possible. Examples:+--+-- * Rewrites @P(L,L)@ (e.g., arguments @Boxed@, @[L,L]@) to @L@+-- * Rewrites @!P(L,L)@ (e.g., arguments @Unboxed@, @[L,L]@) to @!L@+-- * Does not rewrite @P(1L)@, @P(L!L)@ or @P(L,A)@+--+mkProd :: Boxity -> [Demand] -> SubDemand+mkProd b ds+ | all (== AbsDmd) ds = Poly b C_00+ | all (== BotDmd) ds = Poly b C_10+ | dmd@(n :* Poly Boxed m):_ <- ds -- don't rewrite P(L!L)+ , n == m -- don't rewrite P(1L)+ , all (== dmd) ds -- don't rewrite P(L,A)+ = Poly b n+ | otherwise = Prod b ds -- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly' -- demands as necessary.-viewProd :: Arity -> SubDemand -> Maybe [Demand]+viewProd :: Arity -> SubDemand -> Maybe (Boxity, [Demand]) -- It's quite important that this function is optimised well;--- it is used by lubSubDmd and plusSubDmd. Note the strict--- application to 'polyDmd':-viewProd n (Prod ds) | ds `lengthIs` n = Just ds+-- it is used by lubSubDmd and plusSubDmd.+viewProd n (Prod b ds)+ | ds `lengthIs` n = Just (b, ds) -- Note the strict application to replicate: This makes sure we don't allocate -- a thunk for it, inlines it and lets case-of-case fire at call sites.-viewProd n (Poly card) = Just $! (replicate n $! polyDmd card)-viewProd _ _ = Nothing+viewProd n (Poly b card)+ | let !ds = replicate n $! polyFieldDmd card+ = Just (b, ds)+viewProd _ _+ = Nothing {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation -- for Arity. Otherwise, #18304 bites us. @@ -483,38 +758,54 @@ -- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's -- when possible. mkCall :: CardNonAbs -> SubDemand -> SubDemand-mkCall C_1N sd@(Poly C_1N) = sd-mkCall C_0N sd@(Poly C_0N) = sd-mkCall n cd = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $- Call n cd+mkCall C_1N sd@(Poly Boxed C_1N) = sd+mkCall C_0N sd@(Poly Boxed C_0N) = sd+mkCall n cd = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $+ Call n cd +-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as+-- necessary.+viewCall :: SubDemand -> Maybe (Card, SubDemand)+viewCall (Call n sd) = Just (n :: Card, sd)+viewCall (Poly _ n) = Just (n :: Card, Poly Boxed n)+viewCall _ = Nothing+ topDmd, absDmd, botDmd, seqDmd :: Demand-topDmd = polyDmd C_0N+topDmd = C_0N :* topSubDmd absDmd = AbsDmd botDmd = BotDmd seqDmd = C_11 :* seqSubDmd +-- | Sets 'Boxity' to 'Unboxed' for non-'Call' sub-demands.+unboxSubDemand :: SubDemand -> SubDemand+unboxSubDemand (Poly _ n) = Poly Unboxed n+unboxSubDemand (Prod _ ds) = mkProd Unboxed ds+unboxSubDemand sd@Call{} = sd+ -- | Denotes '∪' on 'SubDemand'. lubSubDmd :: SubDemand -> SubDemand -> SubDemand -- Handle botSubDmd (just an optimisation, the general case would do the same)-lubSubDmd (Poly C_10) d2 = d2-lubSubDmd d1 (Poly C_10) = d1+lubSubDmd (Poly Unboxed C_10) d2 = d2+lubSubDmd d1 (Poly Unboxed C_10) = d1 -- Handle Prod-lubSubDmd (Prod ds1) (Poly n2) = Prod $ strictMap (lubDmd (polyDmd n2)) ds1-lubSubDmd (Prod ds1) (Prod ds2)- | equalLength ds1 ds2 = Prod $ strictZipWith lubDmd ds1 ds2+lubSubDmd (Prod b1 ds1) (Poly b2 n2)+ | let !d = polyFieldDmd n2+ = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1)+lubSubDmd (Prod b1 ds1) (Prod b2 ds2)+ | equalLength ds1 ds2+ = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) -- Handle Call-lubSubDmd (Call n1 sd1) (Poly n2)+lubSubDmd (Call n1 sd1) sd2@(Poly _ n2) -- See Note [Call demands are relative] | isAbs n2 = mkCall (lubCard n2 n1) sd1- | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 (Poly n2))+ | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 sd2) lubSubDmd (Call n1 d1) (Call n2 d2) | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2) -- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).-lubSubDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2)-lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1+lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2)+lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top-lubSubDmd _ _ = topSubDmd+lubSubDmd _ _ = topSubDmd -- | Denotes '∪' on 'Demand'. lubDmd :: Demand -> Demand -> Demand@@ -523,24 +814,27 @@ -- | Denotes '+' on 'SubDemand'. plusSubDmd :: SubDemand -> SubDemand -> SubDemand -- Handle seqSubDmd (just an optimisation, the general case would do the same)-plusSubDmd (Poly C_00) d2 = d2-plusSubDmd d1 (Poly C_00) = d1+plusSubDmd (Poly Unboxed C_00) d2 = d2+plusSubDmd d1 (Poly Unboxed C_00) = d1 -- Handle Prod-plusSubDmd (Prod ds1) (Poly n2) = Prod $ strictMap (plusDmd (polyDmd n2)) ds1-plusSubDmd (Prod ds1) (Prod ds2)- | equalLength ds1 ds2 = Prod $ strictZipWith plusDmd ds1 ds2+plusSubDmd (Prod b1 ds1) (Poly b2 n2)+ | let !d = polyFieldDmd n2+ = mkProd (plusBoxity b1 b2) (strictMap (plusDmd d) ds1)+plusSubDmd (Prod b1 ds1) (Prod b2 ds2)+ | equalLength ds1 ds2+ = mkProd (plusBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) -- Handle Call-plusSubDmd (Call n1 d1) (Poly n2)+plusSubDmd (Call n1 sd1) sd2@(Poly _ n2) -- See Note [Call demands are relative]- | isAbs n2 = mkCall (plusCard n2 n1) d1- | otherwise = mkCall (plusCard n2 n1) (lubSubDmd d1 (Poly n2))-plusSubDmd (Call n1 d1) (Call n2 d2)- | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1 d2)--- Handle Poly. Exploit (so we'll match the Prod or Call cases again).-plusSubDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2)-plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1+ | isAbs n2 = mkCall (plusCard n2 n1) sd1+ | otherwise = mkCall (plusCard n2 n1) (lubSubDmd sd1 sd2)+plusSubDmd (Call n1 sd1) (Call n2 sd2)+ | otherwise = mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2)+-- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).+plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (plusBoxity b1 b2) (plusCard n1 n2)+plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top-plusSubDmd _ _ = topSubDmd+plusSubDmd _ _ = topSubDmd -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand@@ -549,11 +843,11 @@ multSubDmd :: Card -> SubDemand -> SubDemand multSubDmd C_11 sd = sd multSubDmd C_00 _ = seqSubDmd-multSubDmd C_10 (Poly n) = if isStrict n then botSubDmd else seqSubDmd+multSubDmd C_10 (Poly _ n) = if isStrict n then botSubDmd else seqSubDmd multSubDmd C_10 (Call n _) = if isStrict n then botSubDmd else seqSubDmd-multSubDmd n (Poly m) = Poly (multCard n m)+multSubDmd n (Poly b m) = Poly b (multCard n m) multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]-multSubDmd n (Prod ds) = Prod (strictMap (multDmd n) ds)+multSubDmd n (Prod b ds) = mkProd b (strictMap (multDmd n) ds) multDmd :: Card -> Demand -> Demand -- The first two lines compute the same result as the last line, but won't@@ -578,11 +872,6 @@ isStrUsedDmd :: Demand -> Bool isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) -isSeqDmd :: Demand -> Bool-isSeqDmd (C_11 :* sd) = sd == seqSubDmd-isSeqDmd (C_1N :* sd) = sd == seqSubDmd-isSeqDmd _ = False- -- | Is the value used at most once? isUsedOnceDmd :: Demand -> Bool isUsedOnceDmd (n :* _) = isUsedOnce n@@ -602,9 +891,9 @@ is_plus_idem_dmd BotDmd = True is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd- is_plus_idem_sub_dmd (Poly n) = assert (isCardNonOnce n) True- is_plus_idem_sub_dmd (Prod ds) = all is_plus_idem_dmd ds- is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative]+ is_plus_idem_sub_dmd (Poly _ n) = assert (isCardNonOnce n) True+ is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds+ is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] evalDmd :: Demand evalDmd = C_1N :* topSubDmd@@ -637,7 +926,7 @@ -- | Make a 'Demand' evaluated at-least-once (e.g. strict). strictifyDmd :: Demand -> Demand-strictifyDmd AbsDmd = BotDmd+strictifyDmd AbsDmd = seqDmd strictifyDmd BotDmd = BotDmd strictifyDmd (n :* sd) = plusCard C_10 n :* sd @@ -646,17 +935,11 @@ -- strictify the argument's contained used non-newtype superclass dictionaries. -- We use the demand as our recursive measure to guarantee termination. strictifyDictDmd :: Type -> Demand -> Demand-strictifyDictDmd ty (n :* Prod ds)+strictifyDictDmd ty (n :* Prod b ds) | not (isAbs n) , Just field_tys <- as_non_newtype_dict ty- = C_1N :* -- main idea: ensure it's strict- if all (not . isAbsDmd) ds- then topSubDmd -- abstract to strict w/ arbitrary component use,- -- since this smells like reboxing; results in CBV- -- boxed- --- -- TODO revisit this if we ever do boxity analysis- else Prod (zipWith strictifyDictDmd field_tys ds)+ = C_1N :* mkProd b (zipWith strictifyDictDmd field_tys ds)+ -- main idea: ensure it's strict where -- | Return a TyCon and a list of field types if the given -- type is a non-newtype dictionary type@@ -678,13 +961,6 @@ mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity --- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'TopSubDmd' and--- 'SeqSubDmd' as necessary.-viewCall :: SubDemand -> Maybe (Card, SubDemand)-viewCall (Call n sd) = Just (n :: Card, sd)-viewCall (Poly n) = Just (n :: Card, Poly n)-viewCall _ = Nothing- -- | Peels one call level from the sub-demand, and also returns how many -- times we entered the lambda body. peelCallDmd :: SubDemand -> (Card, SubDemand)@@ -706,15 +982,6 @@ where go 0 = topSubDmd go n = Call C_01 $ go (n-1) --- | Precondition: The SubDemand is not a Call-addCaseBndrDmd :: SubDemand -- On the case binder- -> [Demand] -- On the components of the constructor- -> [Demand] -- Final demands for the components of the constructor-addCaseBndrDmd sd alt_dmds- -- See Note [Demand on case-alternative binders]- | Prod ds <- plusSubDmd sd (Prod alt_dmds) = ds- | otherwise = alt_dmds- argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args@@ -810,77 +1077,6 @@ that @g@ above actually gets the @1P(L)@ demand on its second pair component, rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand. -Note [Demand on case-alternative binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The demand on a binder in a case alternative comes- (a) From the demand on the binder itself- (b) From the demand on the case binder-Forgetting (b) led directly to #10148.--Example. Source code:- f x@(p,_) = if p then foo x else True-- foo (p,True) = True- foo (p,q) = foo (q,p)--After strictness analysis:- f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->- case x_an1- of wild_X7 [Dmd=MP(ML,ML)]- { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->- case p_an2 of _ {- False -> GHC.Types.True;- True -> foo wild_X7 }--It's true that ds_dnz is *itself* absent, but the use of wild_X7 means-that it is very much alive and demanded. See #10148 for how the-consequences play out.--This is needed even for non-product types, in case the case-binder-is used but the components of the case alternative are not.--Note [Don't optimise LP(L,L,...) to L]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These two SubDemands:- LP(L,L) (@Prod [topDmd, topDmd]@) and L (@topSubDmd@)-are semantically equivalent, but we do not turn the former into-the latter, for a regrettable-subtle reason. Consider- f p1@(x,y) = (y,x)- g h p2@(_,_) = h p-We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses-@p2@ boxed and we'd have to rebox. So we give @p1@ demand LP(L,L) and @p2@-demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnboxArg', which will-say "unbox" for @p1@ and "don't unbox" for @p2@.--So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to-@topSubDmd@; instead leave it as-is. In effect we are using the UseDmd to do a-little bit of boxity analysis. Not very nice.--Note [L should win]-~~~~~~~~~~~~~~~~~~~-Both in 'lubSubDmd' and 'plusSubDmd' we want @L `plusSubDmd` LP(..))@ to be @L@.-Why? Because U carries the implication the whole thing is used, box and all,-so we don't want to w/w it, cf. Note [Don't optimise LP(L,L,...) to L].-If we use it both boxed and unboxed, then we are definitely using the box,-and so we are quite likely to pay a reboxing cost. So we make U win here.-TODO: Investigate why since 2013, we don't.--Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer--Baseline: (A) Not making Used win (LP(..) wins)-Compare with: (B) making Used win for lub and both-- Min -0.3% -5.6% -10.7% -11.0% -33.3%- Max +0.3% +45.6% +11.5% +11.5% +6.9%- Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8%--Baseline: (B) Making L win for both lub and both-Compare with: (C) making L win for plus, but LP(..) win for lub-- Min -0.1% -0.3% -7.9% -8.0% -6.5%- Max +0.1% +1.0% +21.0% +21.0% +0.5%- Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1%- Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call@@ -892,6 +1088,57 @@ The occurrence analyser propagates this one-shot infor to the binders \pqr and \xyz; see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".++Note [Boxity in Poly]+~~~~~~~~~~~~~~~~~~~~~+To support Note [Boxity analysis], it makes sense that 'Prod' carries a+'Boxity'. But why does 'Poly' have to carry a 'Boxity', too? Shouldn't all+'Poly's be 'Boxed'? Couldn't we simply use 'Prod Unboxed' when we need to+express an unboxing demand?++'botSubDmd' (B) needs to be the bottom of the lattice, so it needs to be an+Unboxed demand. Similarly, 'seqSubDmd' (A) is an Unboxed demand.+So why not say that Polys with absent cardinalities have Unboxed boxity?+That doesn't work, because we also need the boxed equivalents. Here's an example+for A (function 'absent' in T19871):+```+f _ True = 1+f a False = a `seq` 2+ -- demand on a: MA, the A is short for `Poly Boxed C_00`++g a = a `seq` f a True+ -- demand on a: SA, which is `Poly Boxed C_00`++h True p = g p -- SA on p (inherited from g)+h False p@(x,y) = x+y -- S!P(1!L,1!L) on p+```+(Caveat: Since Unboxed wins in lubBoxity, we'll unbox here anyway.)+If A is treated as Unboxed, we get reboxing in the call site to 'g'.+So we obviously would need a Boxed variant of A. Rather than introducing a lot+of special cases, we just carry the Boxity in 'Poly'. Plus, we could most likely+find examples like the above for any other cardinality.++Note [Why Boxity in SubDemand and not in Demand?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19871, we started out by storing 'Boxity' in 'SubDemand', in the 'Prod'+constructor only. But then we found that we weren't able to express the unboxing+'seqSubDmd', because that one really is a `Poly C_00` sub-demand.+We then tried to store the Boxity in 'Demand' instead, for these reasons:++ 1. The whole boxity-of-seq business comes to a satisfying conclusion+ 2. Putting Boxity in the SubDemand is weird to begin with, because it+ describes the box and not its fields, just as the evaluation cardinality+ of a Demand describes how often the box is used. It makes more sense that+ Card and Boxity travel together. Also the alternative would have been to+ store Boxity with Poly, which is even weirder and more redundant.++But then we regressed in T7837 (grep #19871 for boring specifics), which needed+to transfer an ambient unboxed *demand* on a dictionary selector to its argument+dictionary, via a 'Call' sub-demand `C1(sd)`, as+Note [Demand transformer for a dictionary selector] explains. Annoyingly,+the boxity info has to be stored in the *sub-demand* `sd`! There's no demand+to store the boxity in. So we bit the bullet and now we store Boxity in+'SubDemand', both in 'Prod' *and* 'Poly'. See also Note [Boxity in Poly]. -} {- *********************************************************************@@ -1289,6 +1536,9 @@ -- See Note [Asymmetry of 'plus*'] -- 'plus' takes the argument/result info from its *first* arg, -- using its second arg just for its free-var info.+ | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd+ = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient+ | otherwise = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) ds1 (r1 `plusDivergence` t2)@@ -1566,10 +1816,10 @@ deriving Eq -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig'--- unleashable at that arity. See Note [Understanding DmdType and DmdSig]+-- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)- | arity < dmdTypeDepth dmd_ty = DmdSig (DmdType fvs (take arity args) div)+ | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig@@ -1671,26 +1921,28 @@ Just dmds -> DmdType emptyDmdEnv dmds topDiv Nothing -> nopDmdType -- Not saturated where- go 0 sd = viewProd arity sd+ go 0 sd = snd <$> viewProd arity sd go n (Call C_11 sd) = go (n-1) sd -- strict calls only! go _ _ = Nothing -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated).+-- See Note [Demand transformer for a dictionary selector]. dmdTransformDictSelSig :: DmdSig -> DmdTransformer--- NB: This currently doesn't handle newtype dictionaries and it's unclear how--- it could without additional parameters.-dmdTransformDictSelSig (DmdSig (DmdType _ [(_ :* sig_sd)] _)) call_sd+-- NB: This currently doesn't handle newtype dictionaries.+-- It should simply apply call_sd directly to the dictionary, I suppose.+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd | (n, sd') <- peelCallDmd call_sd- , Prod sig_ds <- sig_sd+ , Prod _ sig_ds <- prod = multDmdType n $- DmdType emptyDmdEnv [C_11 :* Prod (map (enhance sd') sig_ds)] topDiv+ DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where- enhance sd old | isAbsDmd old = old- | otherwise = C_11 :* sd -- This is the one!-+ enhance _ AbsDmd = AbsDmd+ enhance _ BotDmd = BotDmd+ enhance sd _dmd_var = C_11 :* sd -- This is the one!+ -- C_11, because we multiply with n above dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd) {-@@ -1751,16 +2003,49 @@ Note [Demand transformer for a dictionary selector] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a superclass selector 'sc_sel' and a class method+selector 'op_sel', and a function that uses both, like this++-- Strictness sig: 1P(1,A)+sc_sel (x,y) = x++-- Strictness sig: 1P(A,1)+op_sel (p,q)= q++f d v = op_sel (sc_sel d) v++What do we learn about the demand on 'd'? Alas, we see only the+demand from 'sc_sel', namely '1P(1,A)'. We /don't/ see that 'd' really has a nested+demand '1P(1P(A,1C1(1)),A)'. On the other hand, if we inlined the two selectors+we'd have++f d x = case d of (x,_) ->+ case x of (_,q) ->+ q v++If we analyse that, we'll get a richer, nested demand on 'd'.++We want to behave /as if/ we'd inlined 'op_sel' and 'sc_sel'. We can do this+easily by building a richer demand transformer for dictionary selectors than+is expressible by a regular demand signature.+And that is what 'dmdTransformDictSelSig' does: it transforms the demand on the+result to a demand on the (single) argument.++How does it do that? If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' into the appropriate field of the dictionary. What *is* the appropriate field? We just look at the strictness signature of the class op, which will be-something like: P(AAA1AAAAA). Then replace the '1' by the demand 'd'.+something like: P(AAA1AAAAA). Then replace the '1' (or any other non-absent+demand, really) by the demand 'd'. The '1' acts as if it was a demand variable,+the whole signature really means `\d. P(AAAdAAAAA)` for any incoming+demand 'd'. For single-method classes, which are represented by newtypes the signature of 'op' won't look like P(...), so matching on Prod will fail. That's fine: if we are doing strictness analysis we are also doing inlining, so we'll have inlined 'op' into a cast. So we can bale out in a conservative-way, returning nopDmdType.+way, returning nopDmdType. SG: Although we then probably want to apply the eval+demand 'd' directly to 'op' rather than turning it into 'topSubDmd'... It is (just.. #8329) possible to be running strictness analysis *without* having inlined class ops from single-method classes. Suppose you are using@@ -1818,10 +2103,10 @@ kill_usage_sd :: KillFlags -> SubDemand -> SubDemand kill_usage_sd kfs (Call n sd)- | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)- | otherwise = mkCall n (kill_usage_sd kfs sd)-kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)-kill_usage_sd _ sd = sd+ | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)+ | otherwise = mkCall n (kill_usage_sd kfs sd)+kill_usage_sd kfs (Prod b ds) = mkProd b (map (kill_usage kfs) ds)+kill_usage_sd _ sd = sd {- ********************************************************************* * *@@ -1843,12 +2128,22 @@ trimToType (n :* sd) ts = n :* go sd ts where- go (Prod ds) (TsProd tss)- | equalLength ds tss = Prod (zipWith trimToType ds tss)+ go (Prod b ds) (TsProd tss)+ | equalLength ds tss = mkProd b (zipWith trimToType ds tss) go (Call n sd) (TsFun ts) = mkCall n (go sd ts) go sd@Poly{} _ = sd go _ _ = topSubDmd +-- | Drop all boxity+trimBoxity :: Demand -> Demand+trimBoxity AbsDmd = AbsDmd+trimBoxity BotDmd = BotDmd+trimBoxity (n :* sd) = n :* go sd+ where+ go (Poly _ n) = Poly Boxed n+ go (Prod _ ds) = mkProd Boxed (map trimBoxity ds)+ go (Call n sd) = mkCall n $ go sd+ {- ************************************************************************ * *@@ -1863,9 +2158,9 @@ seqDemand (_ :* sd) = seqSubDemand sd seqSubDemand :: SubDemand -> ()-seqSubDemand (Prod ds) = seqDemandList ds+seqSubDemand (Prod _ ds) = seqDemandList ds seqSubDemand (Call _ sd) = seqSubDemand sd-seqSubDemand (Poly _) = ()+seqSubDemand (Poly _ _) = () seqDemandList :: [Demand] -> () seqDemandList = foldr (seq . seqDemand) ()@@ -1905,19 +2200,21 @@ For pretty-printing demands, we use quite a compact notation with some abbreviations. Here's the BNF: - card ::= B {}- | A {0}- | M {0,1}- | L {0,1,n}- | 1 {1}- | S {1,n}+ card ::= B {}+ | A {0}+ | M {0,1}+ | L {0,1,n}+ | 1 {1}+ | S {1,n} + box ::= ! Unboxed+ | <empty> Boxed+ d ::= card sd The :* constructor, just juxtaposition- | card abbreviation: Same as "card card",- in code @polyDmd card@+ | card abbreviation: Same as "card card" - sd ::= card @Poly card@- | P(d,d,..) @Prod [d1,d2,..]@+ sd ::= box card @Poly box card@+ | box P(d,d,..) @Prod box [d1,d2,..]@ | Ccard(sd) @Call card sd@ So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',@@ -1957,22 +2254,26 @@ -- | See Note [Demand notation] instance Outputable Demand where- ppr AbsDmd = char 'A'- ppr BotDmd = char 'B'- ppr (C_0N :* Poly C_0N) = char 'L' -- Print LL as just L- ppr (C_1N :* Poly C_1N) = char 'S' -- Dito SS- ppr (n :* sd) = ppr n <> ppr sd+ ppr AbsDmd = char 'A'+ ppr BotDmd = char 'B'+ ppr (C_0N :* Poly Boxed C_0N) = char 'L' -- Print LL as just L+ ppr (C_1N :* Poly Boxed C_1N) = char 'S' -- Dito SS+ ppr (n :* sd) = ppr n <> ppr sd -- | See Note [Demand notation] instance Outputable SubDemand where- ppr (Poly sd) = ppr sd+ ppr (Poly b sd) = pp_boxity b <> ppr sd ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)- ppr (Prod ds) = char 'P' <> parens (fields ds)+ ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds) where fields [] = empty fields [x] = ppr x fields (x:xs) = ppr x <> char ',' <> fields xs +pp_boxity :: Boxity -> SDoc+pp_boxity Unboxed = char '!'+pp_boxity _ = empty+ instance Outputable Divergence where ppr Diverges = char 'b' -- for (b)ottom ppr ExnOrDiv = char 'x' -- for e(x)ception@@ -2026,15 +2327,15 @@ _ -> (n :*) <$> get bh instance Binary SubDemand where- put_ bh (Poly sd) = putByte bh 0 *> put_ bh sd+ put_ bh (Poly b sd) = putByte bh 0 *> put_ bh b *> put_ bh sd put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd- put_ bh (Prod ds) = putByte bh 2 *> put_ bh ds+ put_ bh (Prod b ds) = putByte bh 2 *> put_ bh b *> put_ bh ds get bh = do h <- getByte bh case h of- 0 -> Poly <$> get bh+ 0 -> Poly <$> get bh <*> get bh 1 -> mkCall <$> get bh <*> get bh- 2 -> Prod <$> get bh+ 2 -> Prod <$> get bh <*> get bh _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) instance Binary DmdSig where
compiler/GHC/Types/Error.hs view
@@ -41,6 +41,7 @@ , suggestExtensionsWithInfo , suggestAnyExtension , suggestAnyExtensionWithInfo+ , useExtensionInOrderTo , noHints -- * Rendering Messages
compiler/GHC/Types/Hint.hs view
@@ -11,6 +11,7 @@ , suggestExtensionsWithInfo , suggestAnyExtension , suggestAnyExtensionWithInfo+ , useExtensionInOrderTo ) where import GHC.Prelude@@ -38,10 +39,16 @@ -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') data LanguageExtensionHint- = -- | Suggest to enable the input extension. If the input 'SDoc'- -- is not empty, it will contain some extra information about the- -- why the extension is required, but it's totally irrelevant/redundant- -- for IDEs and other tools.+ = -- | Suggest to enable the input extension. This is the hint that+ -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving+ -- its best guess on what extension might be necessary to make a+ -- certain program compile. For example, GHC might suggests to+ -- enable 'BlockArguments' when the user simply formatted incorrectly+ -- the input program, so GHC here is trying to be as helpful as+ -- possible.+ -- If the input 'SDoc' is not empty, it will contain some extra+ -- information about the why the extension is required, but+ -- it's totally irrelevant/redundant for IDEs and other tools. SuggestSingleExtension !SDoc !LangExt.Extension -- | Suggest to enable the input extensions. The list -- is to be intended as /disjuctive/ i.e. the user is@@ -57,6 +64,17 @@ -- information about the why the extensions are required, but -- it's totally irrelevant/redundant for IDEs and other tools. | SuggestExtensions !SDoc [LangExt.Extension]+ -- | Suggest to enable the input extension in order to fix+ -- a certain problem. This is the suggestion that GHC emits when+ -- is more-or-less clear \"what's going on\". For example, if+ -- both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are+ -- turned on, the right thing to do is to enabled 'DerivingStrategies',+ -- so in contrast to 'SuggestSingleExtension' GHC will be a bit more+ -- \"imperative\" (i.e. \"Use X Y Z in order to ... \").+ -- If the input 'SDoc' is not empty, it will contain some extra+ -- information about the why the extensions are required, but+ -- it's totally irrelevant/redundant for IDEs and other tools.+ | SuggestExtensionInOrderTo !SDoc !LangExt.Extension -- | Suggests a single extension without extra user info. suggestExtension :: LangExt.Extension -> GhcHint@@ -82,6 +100,9 @@ suggestAnyExtensionWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint suggestAnyExtensionWithInfo extraInfo exts = SuggestExtension (SuggestAnyExtension extraInfo exts) +useExtensionInOrderTo :: SDoc -> LangExt.Extension -> GhcHint+useExtensionInOrderTo extraInfo ext = SuggestExtension (SuggestExtensionInOrderTo extraInfo ext)+ -- | A type for hints emitted by GHC. -- A /hint/ suggests a possible way to deal with a particular warning or error. data GhcHint@@ -268,6 +289,25 @@ typecheck/should_compile/T4912 -} | SuggestFixOrphanInstance++ {-| Suggests to use a standalone deriving declaration when GHC+ can't derive a typeclass instance in a trivial way.++ Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor'+ Test cases(s): typecheck/should_fail/tcfail086+ -}+ | SuggestAddStandaloneDerivation++ {-| Suggests the user to fill in the wildcard constraint to+ disambiguate which constraint that is.++ Example:+ deriving instance _ => Eq (Foo f a)++ Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor'+ Test cases(s): partial-sigs/should_fail/T13324_fail2+ -}+ | SuggestFillInWildcardConstraint -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
compiler/GHC/Types/Hint/Ppr.hs view
@@ -34,6 +34,8 @@ SuggestExtensions extraUserInfo exts -> let header = text "Enable all of the following extensions:" in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo+ SuggestExtensionInOrderTo extraUserInfo ext ->+ (text "Use" <+> ppr ext) $$ extraUserInfo SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo@@ -120,6 +122,10 @@ -> vcat [ text "Move the instance declaration to the module of the class or of the type, or" , text "wrap the type with a newtype and declare the instance on the new type." ]+ SuggestAddStandaloneDerivation+ -> text "Use a standalone deriving declaration instead"+ SuggestFillInWildcardConstraint+ -> text "Fill in the wildcard constraint yourself" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
compiler/GHC/Types/Id.hs view
@@ -99,7 +99,7 @@ idCafInfo, idLFInfo_maybe, idOneShotInfo, idStateHackOneShotInfo, idOccInfo,- isNeverLevPolyId,+ isNeverRepPolyId, -- ** Writing 'IdInfo' fields setIdUnfolding, setCaseBndrEvald,@@ -567,7 +567,6 @@ FCallId _ -> True DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc _ -> isCompulsoryUnfolding (idUnfolding id)- -- See Note [Representation-polymorphic Ids] isImplicitId :: Id -> Bool -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other@@ -589,26 +588,6 @@ idIsFrom :: Module -> Id -> Bool idIsFrom mod id = nameIsLocalOrFrom mod (idName id) -{- Note [Representation-polymorphic Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some representation-polymorphic Ids must be applied and inlined, not left-un-saturated. Example:- unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b--This has a compulsory unfolding because we can't lambda-bind those-arguments. But the compulsory unfolding may leave representation-polymorphic-lambdas if it is not applied to enough arguments; e.g. (#14561)- bad :: forall (a :: TYPE r). a -> a- bad = unsafeCoerce#--The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop.-And we want that magic to apply to representation-polymorphic compulsory-inline things.-The easiest way to do this is for hasNoBinding to return True of all things-that have compulsory unfolding. Some Ids with a compulsory unfolding also-have a binding, but it does not harm to say they don't here, and its a very-simple way to fix #14561.--}- isDeadBinder :: Id -> Bool isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) | otherwise = False -- TyVars count as not dead@@ -1011,5 +990,5 @@ `setDmdSigInfo` new_strictness `setCprSigInfo` old_cpr -isNeverLevPolyId :: Id -> Bool-isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo+isNeverRepPolyId :: Id -> Bool+isNeverRepPolyId = isNeverRepPolyIdInfo . idInfo
compiler/GHC/Types/Id/Info.hs view
@@ -83,8 +83,8 @@ TickBoxOp(..), TickBoxId, -- ** Levity info- LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,- isNeverLevPolyIdInfo+ LevityInfo, levityInfo, setNeverRepPoly, setLevityInfoWithType,+ isNeverRepPolyIdInfo ) where import GHC.Prelude@@ -124,7 +124,7 @@ `setDmdSigInfo`, `setCprSigInfo`, `setDemandInfo`,- `setNeverLevPoly`,+ `setNeverRepPoly`, `setLevityInfoWithType` {-@@ -736,12 +736,16 @@ ~~~~~~~~~~~~~~~~~~ Ids store whether or not they can be representation-polymorphic at any amount-of saturation. This is helpful in optimizing the representation polymorphism-check done in the desugarer, where we can usually learn that something is not-representation-polymorphic without actually figuring out its type.-See isExprLevPoly in GHC.Core.Utils for where this info is used.-Storing this is required to prevent perf/compiler/T5631 from blowing up.+of saturation. This is helpful in optimizing representation polymorphism checks,+allowing us to learn that something is not representation-polymorphic without+actually figuring out its type.+See exprHasFixedRuntimeRep in GHC.Core.Utils for where this info is used. +Historical note: this was very important when representation polymorphism+was checked in the desugarer (it was needed to prevent T5631 from blowing up).+It's less important now that the checks happen in the typechecker, but remains useful.+Refer to Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for details+about the new approach being used. -} -- See Note [Levity info]@@ -756,19 +760,19 @@ -- | Marks an IdInfo describing an Id that is never representation-polymorphic -- (even when applied). The Type is only there for checking that it's really -- never representation-polymorphic.-setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo-setNeverLevPoly info ty- = assertPpr (not (resultIsLevPoly ty)) (ppr ty) $+setNeverRepPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo+setNeverRepPoly info ty+ = assertPpr (resultHasFixedRuntimeRep ty) (ppr ty) $ info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } setLevityInfoWithType :: IdInfo -> Type -> IdInfo setLevityInfoWithType info ty- | not (resultIsLevPoly ty)+ | resultHasFixedRuntimeRep ty = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } | otherwise = info -isNeverLevPolyIdInfo :: IdInfo -> Bool-isNeverLevPolyIdInfo info+isNeverRepPolyIdInfo :: IdInfo -> Bool+isNeverRepPolyIdInfo info | NeverLevityPolymorphic <- levityInfo info = True | otherwise = False
compiler/GHC/Types/Id/Make.hs view
@@ -373,13 +373,13 @@ argument is not representation-polymorphic (which it can't be, according to Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, no representation-polymorphic code ends up in the code generator.-The saturation condition is effectively checked by-Note [Detecting forced eta expansion] in GHC.HsToCore.Expr.+The saturation condition is effectively checked in+GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs. However, if we make a *wrapper* for a newtype, we get into trouble.-The saturation condition is no longer checked (because hasNoBinding-returns False) and indeed we generate a forbidden representation-polymorphic-binding.+In that case, we generate a forbidden representation-polymorphic+binding, and we must then ensure that it is always instantiated+at a representation-monomorphic type. The solution is simple, though: just make the newtype wrappers as ephemeral as the newtype workers. In other words, give the wrappers@@ -516,9 +516,12 @@ strict_sig = mkClosedDmdSig [arg_dmd] topDiv arg_dmd | new_tycon = evalDmd- | otherwise = C_1N :*- Prod [ if name == sel_name then evalDmd else absDmd- | sel_name <- sel_names ]+ | otherwise = C_1N :* mkProd Unboxed dict_field_dmds+ where+ -- The evalDmd below is just a placeholder and will be replaced in+ -- GHC.Types.Demand.dmdTransformDictSel+ dict_field_dmds = [ if name == sel_name then evalDmd else absDmd+ | sel_name <- sel_names ] mkDictSelRhs :: Class -> Int -- 0-indexed selector among (superclasses ++ methods)@@ -586,7 +589,7 @@ -- even if arity = 0 `setLevityInfoWithType` wkr_ty -- NB: unboxed tuples have workers, so we can't use- -- setNeverLevPoly+ -- setNeverRepPoly wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con@@ -1300,7 +1303,7 @@ -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr- | otherwise = topCpr+ | otherwise = topCpr info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)@@ -1429,7 +1432,7 @@ proxyHashId = pcMiscPrelId proxyName ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]- `setNeverLevPoly` ty)+ `setNeverRepPoly` ty) where -- proxy# :: forall {k} (a:k). Proxy# k a --@@ -1449,7 +1452,7 @@ where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit)- `setNeverLevPoly` addrPrimTy+ `setNeverRepPoly` addrPrimTy ------------------------------------------------ seqId :: Id -- See Note [seqId magic]@@ -1457,6 +1460,7 @@ where info = noCafIdInfo `setInlinePragInfo` inline_prag `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+ `setArityInfo` arity inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter@@ -1476,17 +1480,19 @@ rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] + arity = 2+ ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where- info = noCafIdInfo `setNeverLevPoly` ty+ info = noCafIdInfo `setNeverRepPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where- info = noCafIdInfo `setNeverLevPoly` ty+ info = noCafIdInfo `setNeverRepPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function]@@ -1494,6 +1500,7 @@ where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+ `setArityInfo` arity ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ mkVisFunTyMany fun_ty fun_ty@@ -1504,6 +1511,7 @@ , openAlphaTyVar, openBetaTyVar , body, x'] $ Var body `App` Var x'+ arity = 2 ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax]@@ -1533,6 +1541,7 @@ where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+ `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ exprType body@@ -1544,6 +1553,7 @@ rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1 , openAlphaTyVar, openBetaTyVar ] body body = mkLams [f,xmult] $ App (Var f) (Var xmult)+ arity = 2 -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax]@@ -1556,6 +1566,7 @@ where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+ `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar , multiplicityTyVar1, multiplicityTyVar2 ] $ mkSpecForAllTys [openAlphaTyVar, openBetaTyVar, openGammaTyVar ] $@@ -1572,6 +1583,7 @@ , multiplicityTyVar1, multiplicityTyVar2 , openAlphaTyVar, openBetaTyVar, openGammaTyVar ] body body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]+ arity = 3 -------------------------------------------------------------------------------- @@ -1580,6 +1592,7 @@ where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+ `setArityInfo` 2 eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] ty = mkInvisForAllTys [ Bndr rv InferredSpec@@ -1792,7 +1805,7 @@ realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] `setOneShotInfo` stateHackOneShot- `setNeverLevPoly` realWorldStatePrimTy)+ `setNeverRepPoly` realWorldStatePrimTy) voidPrimId :: Id -- Global constant :: Void# -- The type Void# is now the same as (# #) (ticket #18441),@@ -1802,7 +1815,7 @@ -- a top-level unlifted value. voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs- `setNeverLevPoly` unboxedUnitTy)+ `setNeverRepPoly` unboxedUnitTy) where rhs = Var (dataConWorkId unboxedUnitDataCon)
compiler/GHC/Types/Literal.hs view
@@ -75,6 +75,7 @@ import GHC.Settings.Constants import GHC.Platform import GHC.Utils.Panic+import GHC.Utils.Encoding import Data.ByteString (ByteString) import Data.Int@@ -576,7 +577,8 @@ -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ mkLitString :: String -> Literal -- stored UTF-8 encoded-mkLitString s = LitString (bytesFS $ mkFastString s)+mkLitString [] = LitString mempty+mkLitString s = LitString (utf8EncodeString s) mkLitBigNat :: Integer -> Literal mkLitBigNat x = assertPpr (x >= 0) (integer x)
compiler/GHC/Types/Name.hs view
@@ -552,11 +552,7 @@ -- For a deterministic lexicographic ordering, use `stableNameCmp`. instance Ord Name where- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }- compare a b = cmpName a b+ compare = cmpName instance Uniquable Name where getUnique = nameUnique
compiler/GHC/Types/Name/Occurrence.hs view
@@ -83,14 +83,14 @@ lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,- alterOccEnv, pprOccEnv,+ alterOccEnv, minusOccEnv, minusOccEnv_C, pprOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, isEmptyOccSet, intersectOccSet,- filterOccSet,+ filterOccSet, occSetToEnv, -- * Tidying up TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,@@ -411,7 +411,11 @@ delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt+minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a +-- | Alters (replaces or removes) those elements of the map that are mentioned in the second map+minusOccEnv_C :: (a -> b -> Maybe a) -> OccEnv a -> OccEnv b -> OccEnv a+ emptyOccEnv = A emptyUFM unitOccEnv x y = A $ unitUFM x y extendOccEnv (A x) y z = A $ addToUFM x y z@@ -431,6 +435,8 @@ delListFromOccEnv (A x) y = A $ delListFromUFM x y filterOccEnv x (A y) = A $ filterUFM x y alterOccEnv fn (A y) k = A $ alterUFM fn y k+minusOccEnv (A x) (A y) = A $ minusUFM x y+minusOccEnv_C fn (A x) (A y) = A $ minusUFM_C fn x y instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x@@ -452,6 +458,8 @@ isEmptyOccSet :: OccSet -> Bool intersectOccSet :: OccSet -> OccSet -> OccSet filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet+-- | Converts an OccSet to an OccEnv (operationally the identity)+occSetToEnv :: OccSet -> OccEnv OccName emptyOccSet = emptyUniqSet unitOccSet = unitUniqSet@@ -465,6 +473,7 @@ isEmptyOccSet = isEmptyUniqSet intersectOccSet = intersectUniqSets filterOccSet = filterUniqSet+occSetToEnv = A . getUniqSet {- ************************************************************************
compiler/GHC/Types/Name/Reader.hs view
@@ -41,7 +41,7 @@ LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope,- localRdrEnvElts, delLocalRdrEnvList,+ localRdrEnvElts, minusLocalRdrEnv, -- * Global mapping of 'RdrName' to 'GlobalRdrElt's GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,@@ -98,6 +98,7 @@ import Data.Data import Data.List( sortBy )+import GHC.Data.Bag {- ************************************************************************@@ -434,9 +435,9 @@ -- This is the point of the NameSet inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv-delLocalRdrEnvList lre@(LRE { lre_env = env }) occs- = lre { lre_env = delListFromOccEnv env occs }+minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv+minusLocalRdrEnv lre@(LRE { lre_env = env }) occs+ = lre { lre_env = minusOccEnv env occs } {- Note [Local bindings with Exact Names]@@ -485,11 +486,11 @@ -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt- = GRE { gre_name :: GreName -- ^ See Note [GreNames]- , gre_par :: Parent -- ^ See Note [Parents]- , gre_lcl :: Bool -- ^ True <=> the thing was defined locally- , gre_imp :: [ImportSpec] -- ^ In scope through these imports- } deriving (Data, Eq)+ = GRE { gre_name :: !GreName -- ^ See Note [GreNames]+ , gre_par :: !Parent -- ^ See Note [Parents]+ , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally+ , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports+ } deriving (Data) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] @@ -671,17 +672,17 @@ = case prov_fn n of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail- , gre_lcl = True, gre_imp = [] }+ , gre_lcl = True, gre_imp = emptyBag } Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail- , gre_lcl = False, gre_imp = [is] }+ , gre_lcl = False, gre_imp = unitBag is } mk_fld_gre fl = case prov_fn (flSelector fl) of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail- , gre_lcl = True, gre_imp = [] }+ , gre_lcl = True, gre_imp = emptyBag } Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail- , gre_lcl = False, gre_imp = [is] }+ , gre_lcl = False, gre_imp = unitBag is } instance HasOccName GlobalRdrElt where occName = greOccName@@ -714,18 +715,18 @@ -- Prerecondition: the greMangledName is always External greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | lcl, Just mod <- greDefinitionModule gre = moduleName mod- | (is:_) <- iss = is_as (is_decl is)+ | Just is <- headMaybe iss = is_as (is_decl is) | otherwise = pprPanic "greQualModName" (ppr gre) greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }- = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)+ = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) where occ = greOccName gre unqual = Unqual occ do_spec decl_spec- | is_qual decl_spec = [qual]- | otherwise = [unqual,qual]+ | is_qual decl_spec = unitBag qual+ | otherwise = listToBag [unqual,qual] where qual = Qual (is_as decl_spec) occ -- the SrcSpan that pprNameProvenance prints out depends on whether@@ -736,7 +737,7 @@ greSrcSpan :: GlobalRdrElt -> SrcSpan greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) | lcl = greDefinitionSrcSpan gre- | (is:_) <- iss = is_dloc (is_decl is)+ | Just is <- headMaybe iss = is_dloc (is_decl is) | otherwise = pprPanic "greSrcSpan" (ppr gre) mkParent :: Name -> AvailInfo -> Parent@@ -896,7 +897,7 @@ where qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) | lcl = Nothing- | otherwise = Just $ map (is_as . is_decl) iss+ | otherwise = Just $ map (is_as . is_decl) (bagToList iss) isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_lcl = lcl }) = lcl@@ -983,14 +984,14 @@ | not lcl, null iss' = Nothing | otherwise = Just (gre { gre_imp = iss' }) where- iss' = filter unQualSpecOK iss+ iss' = filterBag unQualSpecOK iss pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl', null iss' = Nothing | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) where- iss' = filter (qualSpecOK mod) iss+ iss' = filterBag (qualSpecOK mod) iss lcl' = lcl && name_is_from mod name_is_from :: ModuleName -> Bool@@ -1047,7 +1048,7 @@ plusGRE g1 g2 = GRE { gre_name = gre_name g1 , gre_lcl = gre_lcl g1 || gre_lcl g2- , gre_imp = gre_imp g1 ++ gre_imp g2+ , gre_imp = gre_imp g1 `unionBags` gre_imp g2 , gre_par = gre_par g1 `plusParent` gre_par g2 } transformGREs :: (GlobalRdrElt -> GlobalRdrElt)@@ -1067,15 +1068,12 @@ = extendOccEnv_Acc insertGRE Utils.singleton env (greOccName gre) gre -shadowNames :: GlobalRdrEnv -> [GreName] -> GlobalRdrEnv-shadowNames = foldl' shadowName- {- Note [GlobalRdrEnv shadowing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before adding new names to the GlobalRdrEnv we nuke some existing entries;-this is "shadowing". The actual work is done by RdrEnv.shadowName.+this is "shadowing". The actual work is done by RdrEnv.shadowNames. Suppose- env' = shadowName env M.f+ env' = shadowNames env f `extendGlobalRdrEnv` M.f Then: * Looking up (Unqual f) in env' should succeed, returning M.f,@@ -1086,8 +1084,9 @@ * Looking up (Qual X.f) in env', where X /= M, should be the same as looking up (Qual X.f) in env.- That is, shadowName does /not/ delete earlier qualified bindings + That is, shadowNames does /not/ delete earlier qualified bindings+ There are two reasons for shadowing: * The GHCi REPL@@ -1107,9 +1106,10 @@ ghci> True ghci> M.x -- M.x is still in scope! ghci> "Hello"+ So when we add `x = True` we must not delete the `M.x` from the `GlobalRdrEnv`; rather we just want to make it "qualified only";- hence the `mk_fake-imp_spec` in `shadowName`. See also Note+ hence the `set_qual` in `shadowNames`. See also Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context - Data types also have External Names, like Ghci4.T; but we still want@@ -1143,24 +1143,17 @@ At that stage, the class op 'f' will have an Internal name. -} -shadowName :: GlobalRdrEnv -> GreName -> GlobalRdrEnv+shadowNames :: GlobalRdrEnv -> OccEnv a -> GlobalRdrEnv -- Remove certain old GREs that share the same OccName as this new Name. -- See Note [GlobalRdrEnv shadowing] for details-shadowName env new_name- = alterOccEnv (fmap (mapMaybe shadow)) env (occName new_name)+shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres)) where- maybe_new_mod = nameModule_maybe (greNameMangledName new_name)- shadow :: GlobalRdrElt -> Maybe GlobalRdrElt shadow old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) = case greDefinitionModule old_gre of Nothing -> Just old_gre -- Old name is Internal; do not shadow Just old_mod- | Just new_mod <- maybe_new_mod- , new_mod == old_mod -- Old name same as new name; shadow completely- -> Nothing- | null iss' -- Nothing remains -> Nothing @@ -1168,9 +1161,9 @@ -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) where- iss' = lcl_imp ++ mapMaybe shadow_is iss- lcl_imp | lcl = [mk_fake_imp_spec old_gre old_mod]- | otherwise = []+ iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss+ lcl_imp | lcl = listToBag [mk_fake_imp_spec old_gre old_mod]+ | otherwise = emptyBag mk_fake_imp_spec old_gre old_mod -- Urgh! = ImpSpec id_spec ImpAll@@ -1181,13 +1174,8 @@ , is_qual = True , is_dloc = greDefinitionSrcSpan old_gre } - shadow_is :: ImportSpec -> Maybe ImportSpec- shadow_is is@(ImpSpec { is_decl = id_spec })- | Just new_mod <- maybe_new_mod- , is_as id_spec == moduleName new_mod- = Nothing -- Shadow both qualified and unqualified- | otherwise -- Shadow unqualified only- = Just (is { is_decl = id_spec { is_qual = True } })+ set_qual :: ImportSpec -> Maybe ImportSpec+ set_qual is = Just (is { is_decl = (is_decl is) { is_qual = True } }) {-@@ -1351,7 +1339,7 @@ (head pp_provs) where name = greMangledName gre- pp_provs = pp_lcl ++ map pp_is iss+ pp_provs = pp_lcl ++ map pp_is (bagToList iss) pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] pp_is is = sep [ppr is, ppr_defn_site is name]
+ compiler/GHC/Types/PkgQual.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Types.PkgQual where++import GHC.Types.SourceText+import GHC.Unit.Types+import GHC.Utils.Outputable++import Data.Data++-- | Package-qualifier as it was parsed+data RawPkgQual+ = NoRawPkgQual -- ^ No package qualifier+ | RawPkgQual StringLiteral -- ^ Raw package qualifier string.+ deriving (Data)++-- | Package-qualifier after renaming+--+-- Renaming detects if "this" or the unit-id of the home-unit was used as a+-- package qualifier.+data PkgQual+ = NoPkgQual -- ^ No package qualifier+ | ThisPkg UnitId -- ^ Import from home-unit+ | OtherPkg UnitId -- ^ Import from another unit+ deriving (Data)++instance Outputable RawPkgQual where+ ppr = \case+ NoRawPkgQual -> empty+ RawPkgQual (StringLiteral st p _)+ -> pprWithSourceText st (doubleQuotes (ftext p))++instance Outputable PkgQual where+ ppr = \case+ NoPkgQual -> empty+ ThisPkg _ -> doubleQuotes (text "this")+ OtherPkg u -> doubleQuotes (ppr u)++
compiler/GHC/Types/Target.hs view
@@ -21,12 +21,14 @@ -- module. If so, use this instead of the file contents (this -- is for use in an IDE where the file hasn't been saved by -- the user yet).+--+-- These fields are strict because Targets are long lived. data Target = Target {- targetId :: TargetId, -- ^ module or filename- targetAllowObjCode :: Bool, -- ^ object code allowed?- targetUnitId :: UnitId, -- ^ id of the unit this target is part of- targetContents :: Maybe (InputFileBuffer, UTCTime)+ targetId :: !TargetId, -- ^ module or filename+ targetAllowObjCode :: !Bool, -- ^ object code allowed?+ targetUnitId :: !UnitId, -- ^ id of the unit this target is part of+ targetContents :: !(Maybe (InputFileBuffer, UTCTime)) -- ^ Optional in-memory buffer containing the source code GHC should -- use for this target instead of reading it from disk. --@@ -40,9 +42,9 @@ } data TargetId- = TargetModule ModuleName+ = TargetModule !ModuleName -- ^ A module name: search for the file- | TargetFile FilePath (Maybe Phase)+ | TargetFile !FilePath !(Maybe Phase) -- ^ A filename: preprocess & parse it to find the module name. -- If specified, the Phase indicates how to compile this file -- (which phase to start from). Nothing indicates the starting phase
compiler/GHC/Types/Unique.hs view
@@ -273,14 +273,7 @@ showUnique :: Unique -> String showUnique uniq = case unpkUnique uniq of- (tag, u) -> finish_show tag u (iToBase62 u)--finish_show :: Char -> Int -> String -> String-finish_show 't' u _pp_u | u < 26- = -- Special case to make v common tyvars, t1, t2, ...- -- come out as a, b, ... (shorter, easier to read)- [chr (ord 'a' + u)]-finish_show tag _ pp_u = tag : pp_u+ (tag, u) -> tag : iToBase62 u pprUniqueAlways :: Unique -> SDoc -- The "always" means regardless of -dsuppress-uniques
compiler/GHC/Types/Unique/DFM.hs view
@@ -72,6 +72,7 @@ import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable +import qualified Data.IntMap.Strict as MS import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..))@@ -121,7 +122,7 @@ -- | A type of values tagged with insertion time data TaggedVal val = TaggedVal- val+ !val {-# UNPACK #-} !Int -- ^ insertion time deriving stock (Data, Functor, Foldable, Traversable) @@ -174,20 +175,24 @@ -- The new binding always goes to the right of existing ones addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v- = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+ = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i -- Keep the old tag, but insert the new value -- This means that udfmToList typically returns elements -- in the order of insertion, rather than the reverse + -- It is quite critical that the strict insertWith is used as otherwise+ -- the combination function 'tf' is not forced and both old values are retained+ -- in the map.+ addToUDFM_C_Directly :: (elt -> elt -> elt) -- old -> new -> result -> UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_C_Directly f (UDFM m i) u v- = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+ = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal old_v old_i) = TaggedVal (f old_v new_v) old_i@@ -399,7 +404,10 @@ -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2-mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i+mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i+-- Critical this is strict map, otherwise you get a big space leak when reloading+-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable).+-- Modify with care. mapMaybeUDFM :: forall elt1 elt2 key. (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
compiler/GHC/Types/Unique/FM.hs view
@@ -59,6 +59,7 @@ plusUFMList, sequenceUFMList, minusUFM,+ minusUFM_C, intersectUFM, intersectUFM_C, disjointUFM,@@ -66,6 +67,7 @@ nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly,+ mapMaybeUFM, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, partitionUFM, sizeUFM,@@ -314,6 +316,14 @@ minusUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 minusUFM (UFM x) (UFM y) = UFM (M.difference x y) +-- | @minusUFC_C f map1 map2@ returns @map1@, except that every mapping @key+-- |-> value1@ in @map1@ that shares a key with a mapping @key |-> value2@ in+-- @map2@ is altered by @f@: @value1@ is replaced by @f value1 value2@, where+-- 'Just' means that the new value is used and 'Nothing' means that the mapping+-- is deleted.+minusUFM_C :: (elt1 -> elt2 -> Maybe elt1) -> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1+minusUFM_C f (UFM x) (UFM y) = UFM (M.differenceWith f x y)+ intersectUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) @@ -333,6 +343,9 @@ mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM f (UFM m) = UFM (M.map f m) +mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2+mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m)+ mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) @@ -380,9 +393,6 @@ seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> () seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) ()- -- It's OK to use nonDetEltsUFM here because the type guarantees that- -- the only interesting thing this function can do is to force the- -- elements. -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce
compiler/GHC/Types/Var/Env.hs view
@@ -98,7 +98,11 @@ ************************************************************************ -} --- | A set of variables that are in scope at some point+-- | A set of variables that are in scope at some point.+--+-- Note that this is a /superset/ of the variables that are currently in scope.+-- See Note [The InScopeSet invariant].+-- -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. newtype InScopeSet = InScope VarSet@@ -110,6 +114,21 @@ -- lookup is useful (see, for instance, Note [In-scope set as a -- substitution]). + -- Note [The InScopeSet invariant]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- The InScopeSet must include every in-scope variable, but it may also+ -- include other variables.++ -- Its principal purpose is to provide a set of variables to be avoided+ -- when creating a fresh identifier (fresh in the sense that it does not+ -- "shadow" any in-scope binding). To do this we simply have to find one that+ -- does not appear in the InScopeSet. This is done by the key function+ -- GHC.Types.Var.Env.uniqAway.++ -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2+ -- for more detailed motivation. #20419 has further discussion.++ instance Outputable InScopeSet where ppr (InScope s) = text "InScope" <+>@@ -182,7 +201,8 @@ -} -- | @uniqAway in_scope v@ finds a unique that is not used in the--- in-scope set, and gives that to v. See Note [Local uniques].+-- in-scope set, and gives that to v. See Note [Local uniques] and+-- Note [The InScopeSet invariant]. uniqAway :: InScopeSet -> Var -> Var -- It starts with v's current unique, of course, in the hope that it won't -- have to change, and thereafter uses the successor to the last derived unique
compiler/GHC/Unit.hs view
@@ -153,10 +153,6 @@ enough to compile them. As such, indefinite units found in databases only provide module interfaces (the .hi ones this time), not object code. -To distinguish between indefinite and definite unit ids at the type level, we-respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically-wrappers over 'UnitId'.- Unit instantiation / on-the-fly instantiation --------------------------------------------- @@ -224,7 +220,7 @@ 'InstantiatedUnit' has two interesting fields: - * instUnitInstanceOf :: IndefUnitId+ * instUnitInstanceOf :: UnitId -- ^ the indefinite unit that is instantiated * instUnitInsts :: [(ModuleName,(Unit,ModuleName)]@@ -267,7 +263,7 @@ , ... } -TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.+TODO: We should probably have `instanceOf :: Maybe UnitId` instead. Note [Pretty-printing UnitId]
− compiler/GHC/Unit/Finder.hs
@@ -1,655 +0,0 @@-{--(c) The University of Glasgow, 2000-2006---}---{-# LANGUAGE FlexibleContexts #-}---- | Module finder-module GHC.Unit.Finder (- FindResult(..),- InstalledFindResult(..),- FinderOpts(..),- FinderCache,- initFinderCache,- flushFinderCaches,- findImportedModule,- findPluginModule,- findExactModule,- findHomeModule,- findExposedPackageModule,- mkHomeModLocation,- mkHomeModLocation2,- mkHiOnlyModLocation,- mkHiPath,- mkObjPath,- addHomeModuleToFinder,- uncacheModule,- mkStubPaths,-- findObjectLinkableMaybe,- findObjectLinkable,-- -- Hash cache- lookupFileCache- ) where--import GHC.Prelude--import GHC.Platform.Ways--import GHC.Builtin.Names ( gHC_PRIM )--import GHC.Unit.Types-import GHC.Unit.Module-import GHC.Unit.Home-import GHC.Unit.State-import GHC.Unit.Finder.Types--import GHC.Data.FastString-import GHC.Data.Maybe ( expectJust )-import qualified GHC.Data.ShortText as ST--import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic--import GHC.Linker.Types--import GHC.Fingerprint-import Data.IORef-import System.Directory-import System.FilePath-import Control.Monad-import Data.Time-import qualified Data.Map as M---type FileExt = String -- Filename extension-type BaseName = String -- Basename of file---- -------------------------------------------------------------------------------- The Finder---- The Finder provides a thin filesystem abstraction to the rest of--- the compiler. For a given module, it can tell you where the--- source, interface, and object files for that module live.---- It does *not* know which particular package a module lives in. Use--- Packages.lookupModuleInAllUnits for that.---- -------------------------------------------------------------------------------- The finder's cache---initFinderCache :: IO FinderCache-initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv- <*> newIORef M.empty---- remove all the home modules from the cache; package modules are--- assumed to not move around during a session; also flush the file hash--- cache-flushFinderCaches :: FinderCache -> HomeUnit -> IO ()-flushFinderCaches (FinderCache ref file_ref) home_unit = do- atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())- atomicModifyIORef' file_ref $ \_ -> (M.empty, ())- where- is_ext mod _ = not (isHomeInstalledModule home_unit mod)--addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache (FinderCache ref _) key val =- atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())--removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()-removeFromFinderCache (FinderCache ref _) key =- atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())--lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache (FinderCache ref _) key = do- c <- readIORef ref- return $! lookupInstalledModuleEnv c key--lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint-lookupFileCache (FinderCache _ ref) key = do- c <- readIORef ref- case M.lookup key c of- Nothing -> do- hash <- getFileHash key- atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())- return hash- Just fp -> return fp---- -------------------------------------------------------------------------------- The three external entry points---- | Locations and information the finder cares about.------ Should be taken from 'DynFlags' via 'initFinderOpts'.-data FinderOpts = FinderOpts- { finder_importPaths :: [FilePath]- -- ^ Where are we allowed to look for Modules and Source files- , finder_lookupHomeInterfaces :: Bool- -- ^ When looking up a home module:- --- -- * 'True': search interface files (e.g. in '-c' mode)- -- * 'False': search source files (e.g. in '--make' mode)-- , finder_bypassHiFileCheck :: Bool- -- ^ Don't check that an imported interface file actually exists- -- if it can only be at one location. The interface will be reported- -- as `InstalledFound` even if the file doesn't exist, so this is- -- only useful in specific cases (e.g. to generate dependencies- -- with `ghc -M`)- , finder_ways :: Ways- , finder_enableSuggestions :: Bool- -- ^ If we encounter unknown modules, should we suggest modules- -- that have a similar name.- , finder_hieDir :: Maybe FilePath- , finder_hieSuf :: String- , finder_hiDir :: Maybe FilePath- , finder_hiSuf :: String- , finder_objectDir :: Maybe FilePath- , finder_objectSuf :: String- , finder_stubDir :: Maybe FilePath- }----- | Locate a module that was imported by the user. We have the--- module's name, and possibly a package name. Without a package--- name, this function will use the search path and the known exposed--- packages to find the module, if a package is specified then only--- that package is searched for the module.--findImportedModule- :: FinderCache- -> FinderOpts- -> UnitState- -> HomeUnit- -> ModuleName- -> Maybe FastString- -> IO FindResult-findImportedModule fc fopts units home_unit mod_name mb_pkg =- case mb_pkg of- Nothing -> unqual_import- Just pkg | pkg == fsLit "this" -> home_import -- "this" is special- | otherwise -> pkg_import- where- home_import = findHomeModule fc fopts home_unit mod_name-- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg-- unqual_import = home_import- `orIfNotFound`- findExposedPackageModule fc fopts units mod_name Nothing---- | Locate a plugin module requested by the user, for a compiler--- plugin. This consults the same set of exposed packages as--- 'findImportedModule', unless @-hide-all-plugin-packages@ or--- @-plugin-package@ are specified.-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult-findPluginModule fc fopts units home_unit mod_name =- findHomeModule fc fopts home_unit mod_name- `orIfNotFound`- findExposedPluginPackageModule fc fopts units mod_name---- | Locate a specific 'Module'. The purpose of this function is to--- create a 'ModLocation' for a given 'Module', that is to find out--- where the files associated with this module live. It is used when--- reading the interface for a module mentioned by another interface,--- for example (a "system import").--findExactModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult-findExactModule fc fopts unit_state home_unit mod = do- if isHomeInstalledModule home_unit mod- then findInstalledHomeModule fc fopts home_unit (moduleName mod)- else findPackageModule fc unit_state fopts mod---- -------------------------------------------------------------------------------- Helpers---- | Given a monadic actions @this@ and @or_this@, first execute--- @this@. If the returned 'FindResult' is successful, return--- it; otherwise, execute @or_this@. If both failed, this function--- also combines their failure messages in a reasonable way.-orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult-orIfNotFound this or_this = do- res <- this- case res of- NotFound { fr_paths = paths1, fr_mods_hidden = mh1- , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }- -> do res2 <- or_this- case res2 of- NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2- , fr_pkgs_hidden = ph2, fr_unusables = u2- , fr_suggestions = s2 }- -> return (NotFound { fr_paths = paths1 ++ paths2- , fr_pkg = mb_pkg2 -- snd arg is the package search- , fr_mods_hidden = mh1 ++ mh2- , fr_pkgs_hidden = ph1 ++ ph2- , fr_unusables = u1 ++ u2- , fr_suggestions = s1 ++ s2 })- _other -> return res2- _other -> return res---- | Helper function for 'findHomeModule': this function wraps an IO action--- which would look up @mod_name@ in the file system (the home package),--- and first consults the 'hsc_FC' cache to see if the lookup has already--- been done. Otherwise, do the lookup (with the IO action) and save--- the result in the finder cache and the module location cache (if it--- was successful.)-homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult-homeSearchCache fc home_unit mod_name do_this = do- let mod = mkHomeInstalledModule home_unit mod_name- modLocationCache fc mod do_this--findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> Maybe FastString -> IO FindResult-findExposedPackageModule fc fopts units mod_name mb_pkg =- findLookupResult fc fopts- $ lookupModuleWithSuggestions units mod_name mb_pkg--findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult-findExposedPluginPackageModule fc fopts units mod_name =- findLookupResult fc fopts- $ lookupPluginModuleWithSuggestions units mod_name Nothing--findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult-findLookupResult fc fopts r = case r of- LookupFound m pkg_conf -> do- let im = fst (getModuleInstantiation m)- r' <- findPackageModule_ fc fopts im (fst pkg_conf)- case r' of- -- TODO: ghc -M is unlikely to do the right thing- -- with just the location of the thing that was- -- instantiated; you probably also need all of the- -- implicit locations from the instances- InstalledFound loc _ -> return (Found loc m)- InstalledNoPackage _ -> return (NoPackage (moduleUnit m))- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)- , fr_pkgs_hidden = []- , fr_mods_hidden = []- , fr_unusables = []- , fr_suggestions = []})- LookupMultiple rs ->- return (FoundMultiple rs)- LookupHidden pkg_hiddens mod_hiddens ->- return (NotFound{ fr_paths = [], fr_pkg = Nothing- , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens- , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens- , fr_unusables = []- , fr_suggestions = [] })- LookupUnusable unusable ->- let unusables' = map get_unusable unusable- get_unusable (m, ModUnusable r) = (moduleUnit m, r)- get_unusable (_, r) =- pprPanic "findLookupResult: unexpected origin" (ppr r)- in return (NotFound{ fr_paths = [], fr_pkg = Nothing- , fr_pkgs_hidden = []- , fr_mods_hidden = []- , fr_unusables = unusables'- , fr_suggestions = [] })- LookupNotFound suggest -> do- let suggest'- | finder_enableSuggestions fopts = suggest- | otherwise = []- return (NotFound{ fr_paths = [], fr_pkg = Nothing- , fr_pkgs_hidden = []- , fr_mods_hidden = []- , fr_unusables = []- , fr_suggestions = suggest' })--modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult-modLocationCache fc mod do_this = do- m <- lookupFinderCache fc mod- case m of- Just result -> return result- Nothing -> do- result <- do_this- addToFinderCache fc mod result- return result---- This returns a module because it's more convenient for users-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module-addHomeModuleToFinder fc home_unit mod_name loc = do- let mod = mkHomeInstalledModule home_unit mod_name- addToFinderCache fc mod (InstalledFound loc mod)- return (mkHomeModule home_unit mod_name)--uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()-uncacheModule fc home_unit mod_name = do- let mod = mkHomeInstalledModule home_unit mod_name- removeFromFinderCache fc mod---- -------------------------------------------------------------------------------- The internal workers--findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult-findHomeModule fc fopts home_unit mod_name = do- let uid = homeUnitAsUnit home_unit- r <- findInstalledHomeModule fc fopts home_unit mod_name- return $ case r of- InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)- InstalledNoPackage _ -> NoPackage uid -- impossible- InstalledNotFound fps _ -> NotFound {- fr_paths = fps,- fr_pkg = Just uid,- fr_mods_hidden = [],- fr_pkgs_hidden = [],- fr_unusables = [],- fr_suggestions = []- }---- | Implements the search for a module name in the home package only. Calling--- this function directly is usually *not* what you want; currently, it's used--- as a building block for the following operations:------ 1. When you do a normal package lookup, we first check if the module--- is available in the home module, before looking it up in the package--- database.------ 2. When you have a package qualified import with package name "this",--- we shortcut to the home module.------ 3. When we look up an exact 'Module', if the unit id associated with--- the module is the current home module do a look up in the home module.------ 4. Some special-case code in GHCi (ToDo: Figure out why that needs to--- call this.)-findInstalledHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO InstalledFindResult-findInstalledHomeModule fc fopts home_unit mod_name = do- homeSearchCache fc home_unit mod_name $- let- home_path = finder_importPaths fopts- hisuf = finder_hiSuf fopts- mod = mkHomeInstalledModule home_unit mod_name-- source_exts =- [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")- , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs")- , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig")- , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")- ]-- -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that- -- when hiDir field is set in dflags, we know to look there (see #16500)- hi_exts = [ (hisuf, mkHomeModHiOnlyLocation fopts mod_name)- , (addBootSuffix hisuf, mkHomeModHiOnlyLocation fopts mod_name)- ]-- -- In compilation manager modes, we look for source files in the home- -- package because we can compile these automatically. In one-shot- -- compilation mode we look for .hi and .hi-boot files only.- exts | finder_lookupHomeInterfaces fopts = hi_exts- | otherwise = source_exts- in-- -- special case for GHC.Prim; we won't find it in the filesystem.- -- This is important only when compiling the base package (where GHC.Prim- -- is a home module).- if mod `installedModuleEq` gHC_PRIM- then return (InstalledFound (error "GHC.Prim ModLocation") mod)- else searchPathExts home_path mod exts----- | Search for a module in external packages only.-findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult-findPackageModule fc unit_state fopts mod = do- let pkg_id = moduleUnit mod- case lookupUnitId unit_state pkg_id of- Nothing -> return (InstalledNoPackage pkg_id)- Just u -> findPackageModule_ fc fopts mod u---- | Look up the interface file associated with module @mod@. This function--- requires a few invariants to be upheld: (1) the 'Module' in question must--- be the module identifier of the *original* implementation of a module,--- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2)--- the 'UnitInfo' must be consistent with the unit id in the 'Module'.--- The redundancy is to avoid an extra lookup in the package state--- for the appropriate config.-findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult-findPackageModule_ fc fopts mod pkg_conf = do- massertPpr (moduleUnit mod == unitId pkg_conf)- (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))- modLocationCache fc mod $-- -- special case for GHC.Prim; we won't find it in the filesystem.- if mod `installedModuleEq` gHC_PRIM- then return (InstalledFound (error "GHC.Prim ModLocation") mod)- else-- let- tag = waysBuildTag (finder_ways fopts)-- -- hi-suffix for packages depends on the build tag.- package_hisuf | null tag = "hi"- | otherwise = tag ++ "_hi"-- mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf-- import_dirs = map ST.unpack $ unitImportDirs pkg_conf- -- we never look for a .hi-boot file in an external package;- -- .hi-boot files only make sense for the home package.- in- case import_dirs of- [one] | finder_bypassHiFileCheck fopts -> do- -- there's only one place that this .hi file can be, so- -- don't bother looking for it.- let basename = moduleNameSlashes (moduleName mod)- loc <- mk_hi_loc one basename- return (InstalledFound loc mod)- _otherwise ->- searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]---- -------------------------------------------------------------------------------- General path searching--searchPathExts :: [FilePath] -- paths to search- -> InstalledModule -- module name- -> [ (- FileExt, -- suffix- FilePath -> BaseName -> IO ModLocation -- action- )- ]- -> IO InstalledFindResult--searchPathExts paths mod exts = search to_search- where- basename = moduleNameSlashes (moduleName mod)-- to_search :: [(FilePath, IO ModLocation)]- to_search = [ (file, fn path basename)- | path <- paths,- (ext,fn) <- exts,- let base | path == "." = basename- | otherwise = path </> basename- file = base <.> ext- ]-- search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))-- search ((file, mk_result) : rest) = do- b <- doesFileExist file- if b- then do { loc <- mk_result; return (InstalledFound loc mod) }- else search rest--mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt- -> FilePath -> BaseName -> IO ModLocation-mkHomeModLocationSearched fopts mod suff path basename =- mkHomeModLocation2 fopts mod (path </> basename) suff---- -------------------------------------------------------------------------------- Constructing a home module location---- This is where we construct the ModLocation for a module in the home--- package, for which we have a source file. It is called from three--- places:------ (a) Here in the finder, when we are searching for a module to import,--- using the search path (-i option).------ (b) The compilation manager, when constructing the ModLocation for--- a "root" module (a source file named explicitly on the command line--- or in a :load command in GHCi).------ (c) The driver in one-shot mode, when we need to construct a--- ModLocation for a source file named on the command-line.------ Parameters are:------ mod--- The name of the module------ path--- (a): The search path component where the source file was found.--- (b) and (c): "."------ src_basename--- (a): (moduleNameSlashes mod)--- (b) and (c): The filename of the source file, minus its extension------ ext--- The filename extension of the source file (usually "hs" or "lhs").--mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> IO ModLocation-mkHomeModLocation dflags mod src_filename = do- let (basename,extension) = splitExtension src_filename- mkHomeModLocation2 dflags mod basename extension--mkHomeModLocation2 :: FinderOpts- -> ModuleName- -> FilePath -- Of source module, without suffix- -> String -- Suffix- -> IO ModLocation-mkHomeModLocation2 fopts mod src_basename ext = do- let mod_basename = moduleNameSlashes mod-- obj_fn = mkObjPath fopts src_basename mod_basename- hi_fn = mkHiPath fopts src_basename mod_basename- hie_fn = mkHiePath fopts src_basename mod_basename-- return (ModLocation{ ml_hs_file = Just (src_basename <.> ext),- ml_hi_file = hi_fn,- ml_obj_file = obj_fn,- ml_hie_file = hie_fn })--mkHomeModHiOnlyLocation :: FinderOpts- -> ModuleName- -> FilePath- -> BaseName- -> IO ModLocation-mkHomeModHiOnlyLocation fopts mod path basename = do- loc <- mkHomeModLocation2 fopts mod (path </> basename) ""- return loc { ml_hs_file = Nothing }--mkHiOnlyModLocation :: FinderOpts -> Suffix -> FilePath -> String- -> IO ModLocation-mkHiOnlyModLocation fopts hisuf path basename- = do let full_basename = path </> basename- obj_fn = mkObjPath fopts full_basename basename- hie_fn = mkHiePath fopts full_basename basename- return ModLocation{ ml_hs_file = Nothing,- ml_hi_file = full_basename <.> hisuf,- -- Remove the .hi-boot suffix from- -- hi_file, if it had one. We always- -- want the name of the real .hi file- -- in the ml_hi_file field.- ml_obj_file = obj_fn,- ml_hie_file = hie_fn- }---- | Constructs the filename of a .o file for a given source file.--- Does /not/ check whether the .o file exists-mkObjPath- :: FinderOpts- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkObjPath fopts basename mod_basename = obj_basename <.> osuf- where- odir = finder_objectDir fopts- osuf = finder_objectSuf fopts-- obj_basename | Just dir <- odir = dir </> mod_basename- | otherwise = basename----- | Constructs the filename of a .hi file for a given source file.--- Does /not/ check whether the .hi file exists-mkHiPath- :: FinderOpts- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkHiPath fopts basename mod_basename = hi_basename <.> hisuf- where- hidir = finder_hiDir fopts- hisuf = finder_hiSuf fopts-- hi_basename | Just dir <- hidir = dir </> mod_basename- | otherwise = basename---- | Constructs the filename of a .hie file for a given source file.--- Does /not/ check whether the .hie file exists-mkHiePath- :: FinderOpts- -> FilePath -- the filename of the source file, minus the extension- -> String -- the module name with dots replaced by slashes- -> FilePath-mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf- where- hiedir = finder_hieDir fopts- hiesuf = finder_hieSuf fopts-- hie_basename | Just dir <- hiedir = dir </> mod_basename- | otherwise = basename------ -------------------------------------------------------------------------------- Filenames of the stub files---- We don't have to store these in ModLocations, because they can be derived--- from other available information, and they're only rarely needed.--mkStubPaths- :: FinderOpts- -> ModuleName- -> ModLocation- -> FilePath--mkStubPaths fopts mod location- = let- stubdir = finder_stubDir fopts-- mod_basename = moduleNameSlashes mod- src_basename = dropExtension $ expectJust "mkStubPaths"- (ml_hs_file location)-- stub_basename0- | Just dir <- stubdir = dir </> mod_basename- | otherwise = src_basename-- stub_basename = stub_basename0 ++ "_stub"- in- stub_basename <.> "h"---- -------------------------------------------------------------------------------- findLinkable isn't related to the other stuff in here,--- but there's no other obvious place for it--findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)-findObjectLinkableMaybe mod locn- = do let obj_fn = ml_obj_file locn- maybe_obj_time <- modificationTimeIfExists obj_fn- case maybe_obj_time of- Nothing -> return Nothing- Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)---- Make an object linkable when we know the object file exists, and we know--- its modification time.-findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])- -- We used to look for _stub.o files here, but that was a bug (#706)- -- Now GHC merges the stub.o into the main .o (#3687)-
compiler/GHC/Unit/Finder/Types.hs view
@@ -3,6 +3,7 @@ , FinderCacheState , FindResult (..) , InstalledFindResult (..)+ , FinderOpts(..) ) where @@ -10,6 +11,7 @@ import GHC.Unit import qualified Data.Map as M import GHC.Fingerprint+import GHC.Platform.Ways import Data.IORef @@ -62,3 +64,35 @@ , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules } +-- | Locations and information the finder cares about.+--+-- Should be taken from 'DynFlags' via 'initFinderOpts'.+data FinderOpts = FinderOpts+ { finder_importPaths :: [FilePath]+ -- ^ Where are we allowed to look for Modules and Source files+ , finder_lookupHomeInterfaces :: Bool+ -- ^ When looking up a home module:+ --+ -- * 'True': search interface files (e.g. in '-c' mode)+ -- * 'False': search source files (e.g. in '--make' mode)++ , finder_bypassHiFileCheck :: Bool+ -- ^ Don't check that an imported interface file actually exists+ -- if it can only be at one location. The interface will be reported+ -- as `InstalledFound` even if the file doesn't exist, so this is+ -- only useful in specific cases (e.g. to generate dependencies+ -- with `ghc -M`)+ , finder_ways :: Ways+ , finder_enableSuggestions :: Bool+ -- ^ If we encounter unknown modules, should we suggest modules+ -- that have a similar name.+ , finder_hieDir :: Maybe FilePath+ , finder_hieSuf :: String+ , finder_hiDir :: Maybe FilePath+ , finder_hiSuf :: String+ , finder_dynHiSuf :: String+ , finder_objectDir :: Maybe FilePath+ , finder_objectSuf :: String+ , finder_dynObjectSuf :: String+ , finder_stubDir :: Maybe FilePath+ }
compiler/GHC/Unit/Home.hs view
@@ -103,7 +103,7 @@ -- produce any code object that rely on the unit id of this virtual unit. homeUnitAsUnit :: HomeUnit -> Unit homeUnitAsUnit (DefiniteHomeUnit u _) = RealUnit (Definite u)-homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u) is+homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit u is -- | Map over the unit identifier for instantiating units homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v
compiler/GHC/Unit/Home/ModInfo.hs view
@@ -7,6 +7,7 @@ , eltsHpt , filterHpt , allHpt+ , anyHpt , mapHpt , delFromHpt , addToHpt@@ -41,10 +42,12 @@ -- ^ The basic loaded interface file: every loaded module has one of -- these, even if it is imported from another package - , hm_details :: !ModDetails+ , hm_details :: ModDetails -- ^ Extra information that has been created from the 'ModIface' for -- the module, typically during typechecking + -- This field is LAZY because a ModDetails is constructed by knot tying.+ , hm_linkable :: !(Maybe Linkable) -- ^ The actual artifact we would like to link to access things in -- this module.@@ -87,6 +90,9 @@ allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool allHpt = allUDFM++anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+anyHpt = anyUDFM mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable mapHpt = mapUDFM
compiler/GHC/Unit/Info.hs view
@@ -60,7 +60,7 @@ -- -- These two identifiers are different for wired-in packages. See Note [About -- Units] in "GHC.Unit"-type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit))+type GenUnitInfo unit = GenericUnitInfo PackageId PackageName unit ModuleName (GenModule (GenUnit unit)) -- | Information about an installed unit (units are identified by their database -- UnitKey)@@ -74,7 +74,6 @@ mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo mkUnitKey'- mkIndefUnitKey' mkPackageIdentifier' mkPackageName' mkModuleName'@@ -84,9 +83,8 @@ mkPackageName' = PackageName . mkFastStringByteString mkUnitKey' = UnitKey . mkFastStringByteString mkModuleName' = mkModuleNameFS . mkFastStringByteString- mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid) mkVirtUnitKey' i = case i of- DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)+ DbInstUnitId cid insts -> mkVirtUnit (mkUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts) DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid)) mkModule' m = case m of DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n)@@ -96,7 +94,6 @@ mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v mapUnitInfo f = mapGenericUnitInfo f -- unit identifier- (fmap f) -- indefinite unit identifier id -- package identifier id -- package name id -- module name
compiler/GHC/Unit/Module.hs view
@@ -106,7 +106,7 @@ -- | Return the unit-id this unit is an instance of and the module instantiations (if any). getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit)-getUnitInstantiations (VirtUnit iuid) = (indefUnit (instUnitInstanceOf iuid), Just iuid)+getUnitInstantiations (VirtUnit iuid) = (instUnitInstanceOf iuid, Just iuid) getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing) getUnitInstantiations HoleUnit = error "Hole unit"
compiler/GHC/Unit/Module/Deps.hs view
@@ -8,6 +8,7 @@ , dep_sig_mods , dep_trusted_pkgs , dep_orphs+ , dep_plugin_pkgs , dep_finsts , dep_boot_mods , dep_orphs_update@@ -56,6 +57,9 @@ -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. + , dep_plugin_pkgs :: Set UnitId+ -- ^ All units needed for plugins+ ------------------------------------ -- Transitive information below here @@ -125,7 +129,7 @@ -- We must also remove self-references from imp_orphs. See -- Note [Module self-dependency] - direct_pkgs = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_units+ direct_pkgs = imp_dep_direct_pkgs imports -- Set the packages required to be Safe according to Safe Haskell. -- See Note [Tracking Trust Transitively] in GHC.Rename.Names@@ -139,6 +143,7 @@ in Deps { dep_direct_mods = direct_mods , dep_direct_pkgs = direct_pkgs+ , dep_plugin_pkgs = plugin_units , dep_sig_mods = sort sig_mods , dep_trusted_pkgs = trust_pkgs , dep_boot_mods = source_mods@@ -164,6 +169,7 @@ instance Binary Dependencies where put_ bh deps = do put_ bh (dep_direct_mods deps) put_ bh (dep_direct_pkgs deps)+ put_ bh (dep_plugin_pkgs deps) put_ bh (dep_trusted_pkgs deps) put_ bh (dep_sig_mods deps) put_ bh (dep_boot_mods deps)@@ -172,6 +178,7 @@ get bh = do dms <- get bh dps <- get bh+ plugin_pkgs <- get bh tps <- get bh hsigms <- get bh sms <- get bh@@ -179,6 +186,7 @@ fis <- get bh return (Deps { dep_direct_mods = dms , dep_direct_pkgs = dps+ , dep_plugin_pkgs = plugin_pkgs , dep_sig_mods = hsigms , dep_boot_mods = sms , dep_trusted_pkgs = tps@@ -189,6 +197,7 @@ noDependencies = Deps { dep_direct_mods = Set.empty , dep_direct_pkgs = Set.empty+ , dep_plugin_pkgs = Set.empty , dep_sig_mods = [] , dep_boot_mods = Set.empty , dep_trusted_pkgs = Set.empty@@ -200,6 +209,7 @@ pprDeps :: UnitState -> Dependencies -> SDoc pprDeps unit_state (Deps { dep_direct_mods = dmods , dep_boot_mods = bmods+ , dep_plugin_pkgs = plgns , dep_orphs = orphs , dep_direct_pkgs = pkgs , dep_trusted_pkgs = tps@@ -209,6 +219,7 @@ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, text "direct package dependencies:" <+> ppr_set ppr pkgs,+ text "plugin package dependencies:" <+> ppr_set ppr plgns, if null tps then empty else text "trusted package dependencies:" <+> ppr_set ppr tps,
compiler/GHC/Unit/Module/Graph.hs view
@@ -193,20 +193,19 @@ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') , char '(' , text (op $ msHsFilePath mod_summary) <> char ','- ] ++- if gopt Opt_BuildDynamicToo dflags- then [ text obj_file <> char ','- , text dyn_file- , char ')'- ]- else [ text obj_file, char ')' ]+ , message, char ')' ]+ where op = normalise mod = moduleName (ms_mod mod_summary) mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)- dyn_file = op $ msDynObjFilePath mod_summary dflags- obj_file = case backend dflags of- Interpreter | recomp -> "interpreted"- NoBackend -> "nothing"- _ -> (op $ msObjFilePath mod_summary)+ dyn_file = op $ msDynObjFilePath mod_summary+ obj_file = op $ msObjFilePath mod_summary+ message = case backend dflags of+ Interpreter | recomp -> text "interpreted"+ NoBackend -> text "nothing"+ _ ->+ if gopt Opt_BuildDynamicToo dflags+ then text obj_file <> comma <+> text dyn_file+ else text obj_file
compiler/GHC/Unit/Module/Location.hs view
@@ -3,6 +3,7 @@ ( ModLocation(..) , addBootSuffix , addBootSuffix_maybe+ , addBootSuffixLocn_maybe , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix@@ -16,7 +17,7 @@ -- | Module Location -- -- Where a module lives on the file system: the actual locations--- of the .hs, .hi and .o files, if we have them.+-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. -- -- For a module in another unit, the ml_hs_file and ml_obj_file components of -- ModLocation are undefined.@@ -25,6 +26,16 @@ -- correspond to actual files yet: for example, even if the object -- file doesn't exist, the ModLocation still contains the path to -- where the object file will reside if/when it is created.+--+-- The paths of anything which can affect recompilation should be placed inside+-- ModLocation.+--+-- When a ModLocation is created none of the filepaths will have -boot suffixes.+-- This is because in --make mode the ModLocation is put in the finder cache which+-- is indexed by ModuleName, when a ModLocation is retrieved from the FinderCache+-- the boot suffixes are appended.+-- The other case is in -c mode, there the ModLocation immediately gets given the+-- boot suffixes in mkOneShotModLocation. data ModLocation = ModLocation {@@ -37,12 +48,20 @@ -- yet. Always of form foo.hi, even if there is an -- hi-boot file (we add the -boot suffix later) + ml_dyn_hi_file :: FilePath,+ -- ^ Where the .dyn_hi file is, whether or not it exists+ -- yet.+ ml_obj_file :: FilePath, -- ^ Where the .o file is, whether or not it exists yet. -- (might not exist either because the module hasn't -- been compiled yet, or because it is part of a -- unit with a .a file) + ml_dyn_obj_file :: FilePath,+ -- ^ Where the .dy file is, whether or not it exists+ -- yet.+ ml_hie_file :: FilePath -- ^ Where the .hie file is, whether or not it exists -- yet.@@ -68,12 +87,19 @@ IsBoot -> addBootSuffix path NotBoot -> path +addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation+addBootSuffixLocn_maybe is_boot locn = case is_boot of+ IsBoot -> addBootSuffixLocn locn+ _ -> locn+ -- | Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) , ml_hi_file = addBootSuffix (ml_hi_file locn)+ , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn)+ , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn) , ml_hie_file = addBootSuffix (ml_hie_file locn) } -- | Add the @-boot@ suffix to all output file paths associated with the@@ -81,7 +107,10 @@ addBootSuffixLocnOut :: ModLocation -> ModLocation addBootSuffixLocnOut locn = locn { ml_hi_file = addBootSuffix (ml_hi_file locn)+ , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn)- , ml_hie_file = addBootSuffix (ml_hie_file locn) }+ , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)+ , ml_hie_file = addBootSuffix (ml_hie_file locn)+ }
compiler/GHC/Unit/Module/ModIface.hs view
@@ -18,11 +18,13 @@ , mi_fix , mi_semantic_module , mi_free_holes+ , mi_mnwib , renameFreeHoles , emptyPartialModIface , emptyFullModIface , mkIfaceHashCache , emptyIfaceHashCache+ , forceModIface ) where @@ -54,6 +56,7 @@ import GHC.Utils.Binary import Control.DeepSeq+import Control.Exception {- Note [Interface file stages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -144,6 +147,9 @@ -- except that we explicitly make the 'mi_decls' and a few other fields empty; -- as when reading we consolidate the declarations etc. into a number of indexed -- maps and environments in the 'ExternalPackageState'.+--+-- See Note [Strictness in ModIface] to learn about why some fields are+-- strict and others are not. data ModIface_ (phase :: ModIfacePhase) = ModIface { mi_module :: !Module, -- ^ Name of the module we are for@@ -227,7 +233,7 @@ -- itself) but imports some trustworthy modules from its own -- package (which does require its own package be trusted). -- See Note [Trust Own Package] in GHC.Rename.Names- mi_complete_matches :: [IfaceCompleteMatch],+ mi_complete_matches :: ![IfaceCompleteMatch], mi_doc_hdr :: Maybe HsDocString, -- ^ Module header.@@ -242,7 +248,7 @@ -- ^ Either `()` or `ModIfaceBackend` for -- a fully instantiated interface. - mi_ext_fields :: ExtensibleFields,+ mi_ext_fields :: !ExtensibleFields, -- ^ Additional optional fields, where the Map key represents -- the field name, resulting in a (size, serialized data) pair. -- Because the data is intended to be serialized through the@@ -255,6 +261,29 @@ -- ^ Hash of the .hs source, used for recompilation checking. } +{-+Note [Strictness in ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModIface is the Haskell representation of an interface (.hi) file.++* During compilation we write out ModIface values to disk for files+ that we have just compiled+* For packages that we depend on we load the ModIface from disk.++Some fields in the ModIface are deliberately lazy because when we read+an interface file we don't always need all the parts. For example, an+interface file contains information about documentation which is often+not needed during compilation. This is achieved using the lazyPut/lazyGet pair.+If the field was strict then we would pointlessly load this information into memory.++On the other hand, if we create a ModIface but **don't** write it to+disk then to avoid space leaks we need to make sure to deepseq all these lazy fields+because the ModIface might live for a long time (for instance in a GHCi session).+That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to+forceModIface.+-}+ -- | Old-style accessor for whether or not the ModIface came from an hs-boot -- file. mi_boot :: ModIface -> IsBootInterface@@ -262,6 +291,9 @@ then IsBoot else NotBoot +mi_mnwib :: ModIface -> ModuleNameWithIsBoot+mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)+ -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. mi_fix :: ModIface -> OccName -> Fixity@@ -303,7 +335,7 @@ -- It wasn't actually a hole | otherwise = emptyUniqDSet -+-- See Note [Strictness in ModIface] about where we use lazyPut vs put instance Binary ModIface where put_ bh (ModIface { mi_module = mod,@@ -527,6 +559,16 @@ f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 `seq` rnf f24 `seq` f25 `seq` ()++instance NFData (ModIfaceBackend) where+ rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+ = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq`+ rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq`+ rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13+++forceModIface :: ModIface -> IO ()+forceModIface iface = () <$ (evaluate $ force iface) -- | Records whether a module has orphans. An \"orphan\" is one of: --
compiler/GHC/Unit/Module/ModSummary.hs view
@@ -16,6 +16,7 @@ , ms_home_srcimps , ms_home_imps , msHiFilePath+ , msDynHiFilePath , msHsFilePath , msObjFilePath , msDynObjFilePath@@ -36,9 +37,9 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceString ) import GHC.Types.SrcLoc import GHC.Types.Target+import GHC.Types.PkgQual import GHC.Data.Maybe-import GHC.Data.FastString import GHC.Data.StringBuffer ( StringBuffer ) import GHC.Utils.Fingerprint@@ -87,11 +88,11 @@ -- See Note [When source is considered modified] and #9243 ms_hie_date :: Maybe UTCTime, -- ^ Timestamp of hie file, if we have one- ms_srcimps :: [(Maybe FastString, Located ModuleName)],+ ms_srcimps :: [(PkgQual, Located ModuleName)], -- FIXME: source imports are never from an external package, why do we allow PkgQual? -- ^ Source imports of the module- ms_textual_imps :: [(Maybe FastString, Located ModuleName)],+ ms_textual_imps :: [(PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text*- ms_ghc_prim_import :: Bool,+ ms_ghc_prim_import :: !Bool, -- ^ Whether the special module GHC.Prim was imported explicitliy ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also@@ -115,19 +116,22 @@ ms_mod_name = moduleName . ms_mod -- | Textual imports, plus plugin imports but not SOURCE imports.-ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]+ms_imps :: ModSummary -> [(PkgQual, Located ModuleName)] ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms -- | Plugin imports-ms_plugin_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]-ms_plugin_imps ms = map ((Nothing,) . noLoc) (pluginModNames (ms_hspp_opts ms))+ms_plugin_imps :: ModSummary -> [(PkgQual, Located ModuleName)]+ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)) -home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,- isLocal mb_pkg ]- where isLocal Nothing = True- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special- isLocal _ = False+-- | All of the (possibly) home module imports from the given list that is to+-- say, each of these module names could be a home import if an appropriately+-- named file existed. (This is in contrast to package qualified imports, which+-- are guaranteed not to be home imports.)+home_imps :: [(PkgQual, Located ModuleName)] -> [Located ModuleName]+home_imps imps = fmap snd (filter (maybe_home . fst) imps)+ where maybe_home NoPkgQual = True+ maybe_home (ThisPkg _) = True+ maybe_home (OtherPkg _) = False -- | Like 'ms_home_imps', but for SOURCE imports. ms_home_srcimps :: ModSummary -> [Located ModuleName]@@ -151,13 +155,12 @@ -- The ModLocation is stable over successive up-sweeps in GHCi, wheres -- the ms_hs_hash and imports can, of course, change -msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath+msHsFilePath, msDynHiFilePath, msHiFilePath, msObjFilePath, msDynObjFilePath :: ModSummary -> FilePath msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) msHiFilePath ms = ml_hi_file (ms_location ms)+msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms)--msDynObjFilePath :: ModSummary -> DynFlags -> FilePath-msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)+msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms) -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> IsBootInterface
compiler/GHC/Unit/Parser.hs view
@@ -1,7 +1,7 @@ -- | Parsers for unit/module identifiers module GHC.Unit.Parser ( parseUnit- , parseIndefUnitId+ , parseUnitId , parseHoleyModule , parseModSubst )@@ -21,7 +21,7 @@ parseUnit = parseVirtUnitId <++ parseDefUnitId where parseVirtUnitId = do- uid <- parseIndefUnitId+ uid <- parseUnitId insts <- parseModSubst return (mkVirtUnit uid insts) parseDefUnitId = do@@ -32,11 +32,6 @@ parseUnitId = do s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") return (UnitId (mkFastString s))--parseIndefUnitId :: ReadP IndefUnitId-parseIndefUnitId = do- uid <- parseUnitId- return (Indefinite uid) parseHoleyModule :: ReadP Module parseHoleyModule = parseModuleVar <++ parseModule
compiler/GHC/Unit/State.hs view
@@ -90,6 +90,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet+import GHC.Types.PkgQual import GHC.Utils.Misc import GHC.Utils.Panic@@ -412,9 +413,11 @@ -- See Note [VirtUnit to RealUnit improvement] preloadClosure :: PreloadUnitClosure, - -- | A mapping of 'PackageName' to 'IndefUnitId'. This is used when- -- users refer to packages in Backpack includes.- packageNameMap :: UniqFM PackageName IndefUnitId,+ -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same+ -- package name (e.g. different instantiations), then we return one of them...+ -- This is used when users refer to packages in Backpack includes.+ -- And also to resolve package qualifiers with the PackageImports extension.+ packageNameMap :: UniqFM PackageName UnitId, -- | A mapping from database unit keys to wired in unit ids. wireMap :: Map UnitId UnitId,@@ -498,7 +501,7 @@ -> -- lookup UnitInfo of the indefinite unit to be instantiated and -- instantiate it on-the-fly fmap (renameUnitInfo pkg_map closure (instUnitInsts i))- (Map.lookup (indefUnit (instUnitInstanceOf i)) pkg_map)+ (Map.lookup (instUnitInstanceOf i) pkg_map) | otherwise -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite@@ -531,7 +534,7 @@ -- | Find the unit we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this)-lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId+lookupPackageName :: UnitState -> PackageName -> Maybe UnitId lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n -- | Search for units with a given package ID (e.g. \"foo-0.1\")@@ -936,7 +939,7 @@ | iuid == unitId p -> Just p VirtUnit inst- | indefUnit (instUnitInstanceOf inst) == unitId p+ | instUnitInstanceOf inst == unitId p -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p) _ -> Nothing @@ -1108,7 +1111,7 @@ where upd_pkg pkg | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap = pkg { unitId = wiredInUnitId- , unitInstanceOf = fmap (const wiredInUnitId) (unitInstanceOf pkg)+ , unitInstanceOf = wiredInUnitId -- every non instantiated unit is an instance of -- itself (required by Backpack...) --@@ -1792,7 +1795,7 @@ -> ModuleName -> [(Module, UnitInfo)] lookupModuleInAllUnits pkgs m- = case lookupModuleWithSuggestions pkgs m Nothing of+ = case lookupModuleWithSuggestions pkgs m NoPkgQual of LookupFound a b -> [(a,fst b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs@@ -1820,7 +1823,7 @@ lookupModuleWithSuggestions :: UnitState -> ModuleName- -> Maybe FastString+ -> PkgQual -> LookupResult lookupModuleWithSuggestions pkgs = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)@@ -1828,7 +1831,7 @@ -- | The package which the module **appears** to come from, this could be -- the one which reexports the module from it's original package. This function -- is currently only used for -Wunused-packages-lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]+lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo] lookupModulePackage pkgs mn mfs = case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of LookupFound _ (orig_unit, origin) ->@@ -1847,7 +1850,7 @@ lookupPluginModuleWithSuggestions :: UnitState -> ModuleName- -> Maybe FastString+ -> PkgQual -> LookupResult lookupPluginModuleWithSuggestions pkgs = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)@@ -1855,7 +1858,7 @@ lookupModuleWithSuggestions' :: UnitState -> ModuleNameProvidersMap -> ModuleName- -> Maybe FastString+ -> PkgQual -> LookupResult lookupModuleWithSuggestions' pkgs mod_map m mb_pn = case Map.lookup m mod_map of@@ -1890,24 +1893,29 @@ -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this -- excluded all origins with 'originEmpty'.- filterOrigin :: Maybe FastString+ filterOrigin :: PkgQual -> UnitInfo -> ModuleOrigin -> ModuleOrigin- filterOrigin Nothing _ o = o- filterOrigin (Just pn) pkg o =- case o of- ModHidden -> if go pkg then ModHidden else mempty- (ModUnusable _) -> if go pkg then o else mempty+ filterOrigin NoPkgQual _ o = o+ filterOrigin (ThisPkg _) _ o = o+ filterOrigin (OtherPkg u) pkg o =+ let match_pkg p = u == unitId p+ in case o of+ ModHidden+ | match_pkg pkg -> ModHidden+ | otherwise -> mempty+ ModUnusable _+ | match_pkg pkg -> o+ | otherwise -> mempty ModOrigin { fromOrigUnit = e, fromExposedReexport = res, fromHiddenReexport = rhs }- -> ModOrigin {- fromOrigUnit = if go pkg then e else Nothing- , fromExposedReexport = filter go res- , fromHiddenReexport = filter go rhs- , fromPackageFlag = False -- always excluded+ -> ModOrigin+ { fromOrigUnit = if match_pkg pkg then e else Nothing+ , fromExposedReexport = filter match_pkg res+ , fromHiddenReexport = filter match_pkg rhs+ , fromPackageFlag = False -- always excluded }- where go pkg = pn == fsPackageName pkg suggestions = fuzzyLookup (moduleNameString m) all_mods @@ -2002,14 +2010,7 @@ -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name =- fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))- where- -- update IndefUnitId ppr info as they may have changed since the- -- time the IndefUnitId was created- fixupModule (Module iud name) = Module iud' name- where- iud' = iud { instUnitInstanceOf = cid' }- cid' = instUnitInstanceOf iud+ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) -- ----------------------------------------------------------------------------- @@ -2017,7 +2018,7 @@ -- -- Cabal packages may contain several components (programs, libraries, etc.). -- As far as GHC is concerned, installed package components ("units") are--- identified by an opaque IndefUnitId string provided by Cabal. As the string+-- identified by an opaque UnitId string provided by Cabal. As the string -- contains a hash, we don't want to display it to users so GHC queries the -- database to retrieve some infos about the original source package (name, -- version, component name).
compiler/GHC/Unit/Types.hs view
@@ -28,7 +28,6 @@ , UnitKey (..) , GenInstantiatedUnit (..) , InstantiatedUnit- , IndefUnitId , DefUnitId , Instantiations , GenInstantiations@@ -54,7 +53,6 @@ -- * Utils , Definite (..)- , Indefinite (..) -- * Wired-in units , primUnitId@@ -248,7 +246,7 @@ -- see Note [VirtUnit to RealUnit improvement]. -- -- An indefinite unit identifier pretty-prints to something like--- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'IndefUnitId', and the+-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'UnitId', and the -- brackets enclose the module substitution). data GenInstantiatedUnit unit = InstantiatedUnit {@@ -258,8 +256,8 @@ instUnitFS :: !FastString, -- | Cached unique of 'unitFS'. instUnitKey :: !Unique,- -- | The indefinite unit being instantiated.- instUnitInstanceOf :: !(Indefinite unit),+ -- | The (indefinite) unit being instantiated.+ instUnitInstanceOf :: !unit, -- | The sorted (by 'ModuleName') instantiations of this unit. instUnitInsts :: !(GenInstantiations unit), -- | A cache of the free module holes of 'instUnitInsts'.@@ -375,7 +373,7 @@ -- | Create a new 'GenInstantiatedUnit' given an explicit module substitution.-mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u+mkInstantiatedUnit :: IsUnitId u => u -> GenInstantiations u -> GenInstantiatedUnit u mkInstantiatedUnit cid insts = InstantiatedUnit { instUnitInstanceOf = cid,@@ -390,8 +388,8 @@ -- | Smart constructor for instantiated GenUnit-mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u-mkVirtUnit uid [] = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole?+mkVirtUnit :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u+mkVirtUnit uid [] = RealUnit $ Definite uid mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts -- | Generate a uniquely identifying hash (internal unit-id) for an instantiated@@ -402,7 +400,7 @@ -- This hash is completely internal to GHC and is not used for symbol names or -- file paths. It is different from the hash Cabal would produce for the same -- instantiated unit.-mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString+mkInstantiatedUnitHash :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> FastString mkInstantiatedUnitHash cid sorted_holes = mkFastStringByteString . fingerprintUnitId (bytesFS (unitFS cid))@@ -451,7 +449,7 @@ RealUnit d -> RealUnit (fmap f d) VirtUnit i -> VirtUnit $ mkInstantiatedUnit- (fmap f (instUnitInstanceOf i))+ (f (instUnitInstanceOf i)) (fmap (second (fmap go)) (instUnitInsts i)) -- | Map over the unit identifier of unit instantiations.@@ -462,7 +460,7 @@ -- the UnitId of the indefinite unit this unit is an instance of. toUnitId :: Unit -> UnitId toUnitId (RealUnit (Definite iuid)) = iuid-toUnitId (VirtUnit indef) = indefUnit (instUnitInstanceOf indef)+toUnitId (VirtUnit indef) = instUnitInstanceOf indef toUnitId HoleUnit = error "Hole unit" -- | Return the virtual UnitId of an on-the-fly instantiated unit.@@ -489,12 +487,12 @@ -- libraries as we can cheaply instantiate them on-the-fly, cf VirtUnit). Put -- another way, an installed unit id is either fully instantiated, or not -- instantiated at all.-newtype UnitId =- UnitId {- -- | The full hashed unit identifier, including the component id+newtype UnitId = UnitId+ { unitIdFS :: FastString+ -- ^ The full hashed unit identifier, including the component id -- and the hash.- unitIdFS :: FastString- }+ }+ deriving (Data) instance Binary UnitId where put_ bh (UnitId fs) = put_ bh fs@@ -532,14 +530,6 @@ -- | A definite unit (i.e. without any free module hole) newtype Definite unit = Definite { unDefinite :: unit }- deriving (Functor)- deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)---- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only--- refers to an indefinite library; i.e., one that can be instantiated.-type IndefUnitId = Indefinite UnitId--newtype Indefinite unit = Indefinite { indefUnit :: unit } deriving (Functor) deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
compiler/GHC/Unit/Types.hs-boot view
@@ -9,11 +9,9 @@ data UnitId data GenModule (unit :: Type) data GenUnit (uid :: Type)-data Indefinite (unit :: Type) type Module = GenModule Unit type Unit = GenUnit UnitId-type IndefUnitId = Indefinite UnitId moduleName :: GenModule a -> ModuleName moduleUnit :: GenModule a -> a
compiler/GHC/Utils/Error.hs view
@@ -10,7 +10,7 @@ module GHC.Utils.Error ( -- * Basic types- Validity(..), andValid, allValid, isValid, getInvalids, orValid,+ Validity'(..), Validity, andValid, allValid, isValid, getInvalids, orValid, Severity(..), -- * Messages@@ -191,27 +191,30 @@ mk_msg_envelope SevError locn alwaysQualify msg --------------------------data Validity- = IsValid -- ^ Everything is fine- | NotValid SDoc -- ^ A problem, and some indication of why+data Validity' a+ = IsValid -- ^ Everything is fine+ | NotValid a -- ^ A problem, and some indication of why -isValid :: Validity -> Bool+-- | Monomorphic version of @Validity'@ specialised for 'SDoc's.+type Validity = Validity' SDoc++isValid :: Validity' a -> Bool isValid IsValid = True isValid (NotValid {}) = False -andValid :: Validity -> Validity -> Validity+andValid :: Validity' a -> Validity' a -> Validity' a andValid IsValid v = v andValid v _ = v -- | If they aren't all valid, return the first-allValid :: [Validity] -> Validity+allValid :: [Validity' a] -> Validity' a allValid [] = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [SDoc]+getInvalids :: [Validity' a] -> [a] getInvalids vs = [d | NotValid d <- vs] -orValid :: Validity -> Validity -> Validity+orValid :: Validity' a -> Validity' a -> Validity' a orValid IsValid _ = IsValid orValid _ v = v
compiler/GHC/Utils/Misc.hs view
@@ -79,7 +79,7 @@ transitiveClosure, -- * Strictness- seqList, strictMap, strictZipWith,+ seqList, strictMap, strictZipWith, strictZipWith3, -- * Module names looksLikeModuleName,@@ -950,10 +950,12 @@ fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup user_entered possibilites = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd)- [ (poss_val, distance) | (poss_str, poss_val) <- possibilites- , let distance = restrictedDamerauLevenshteinDistance- poss_str user_entered- , distance <= fuzzy_threshold ]+ [ (poss_val, sort_key)+ | (poss_str, poss_val) <- possibilites+ , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered+ , distance <= fuzzy_threshold+ , let sort_key = (distance, length poss_str, poss_str)+ ] where -- Work out an appropriate match threshold: -- We report a candidate if its edit distance is <= the threshold,@@ -966,6 +968,10 @@ -- 5 1 -- 6 2 --+ -- Candidates with the same distance are sorted by their length. We also+ -- use the actual string as the third sorting criteria the sort key to get+ -- deterministic output, even if the input may have depended on the uniques+ -- in question fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) mAX_RESULTS = 3 @@ -985,8 +991,8 @@ seqList (x:xs) b = x `seq` seqList xs b strictMap :: (a -> b) -> [a] -> [b]-strictMap _ [] = []-strictMap f (x : xs) =+strictMap _ [] = []+strictMap f (x:xs) = let !x' = f x !xs' = strictMap f xs@@ -994,12 +1000,23 @@ x' : xs' strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]-strictZipWith _ [] _ = []-strictZipWith _ _ [] = []-strictZipWith f (x : xs) (y: ys) =+strictZipWith _ [] _ = []+strictZipWith _ _ [] = []+strictZipWith f (x:xs) (y:ys) = let !x' = f x y !xs' = strictZipWith f xs ys+ in+ x' : xs'++strictZipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]+strictZipWith3 _ [] _ _ = []+strictZipWith3 _ _ [] _ = []+strictZipWith3 _ _ _ [] = []+strictZipWith3 f (x:xs) (y:ys) (z:zs) =+ let+ !x' = f x y z+ !xs' = strictZipWith3 f xs ys zs in x' : xs'
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -973,10 +973,17 @@ -- in Language.Haskell.Syntax.Extension --- | Haskell Array Application Type-data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp- deriving Data+-- | Haskell arrow application type.+data HsArrAppType+ -- | First order arrow application '-<'+ = HsHigherOrderApp+ -- | Higher order arrow application '-<<'+ | HsFirstOrderApp+ deriving Data +pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp = text "first order arrow application" {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an@@ -1674,7 +1681,8 @@ | LambdaExpr -- ^Patterns of a lambda | CaseAlt -- ^Patterns and guards on a case alternative | IfAlt -- ^Guards of a multi-way if alternative- | ProcExpr -- ^Patterns of a proc+ | ArrowMatchCtxt -- ^A pattern match inside arrow notation+ HsArrowMatchContext | PatBindRhs -- ^A pattern binding eg [y] <- e = e | PatBindGuards -- ^Guards of pattern bindings, e.g., -- (Just b) | Just _ <- x = e@@ -1705,6 +1713,12 @@ | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt | ArrowExpr -- ^do-notation in an arrow-command context +-- | Haskell arrow match context.+data HsArrowMatchContext+ = ProcExpr -- ^ A proc expression+ | ArrowCaseAlt -- ^ A case alternative inside arrow notation+ | KappaExpr -- ^ An arrow kappa abstraction+ data HsDoFlavour = DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... } | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression@@ -1767,7 +1781,7 @@ matchSeparator CaseAlt = text "->" matchSeparator IfAlt = text "->" matchSeparator LambdaExpr = text "->"-matchSeparator ProcExpr = text "->"+matchSeparator (ArrowMatchCtxt{})= text "->" matchSeparator PatBindRhs = text "=" matchSeparator PatBindGuards = text "=" matchSeparator (StmtCtxt _) = text "<-"@@ -1783,9 +1797,10 @@ | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt | otherwise = text "a" <+> pprMatchContextNoun ctxt where- want_an (FunRhs {}) = True -- Use "an" in front- want_an ProcExpr = True- want_an _ = False+ want_an (FunRhs {}) = True -- Use "an" in front+ want_an (ArrowMatchCtxt ProcExpr) = True+ want_an (ArrowMatchCtxt KappaExpr) = True+ want_an _ = False pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p) => HsMatchContext p -> SDoc@@ -1800,10 +1815,15 @@ pprMatchContextNoun PatBindRhs = text "pattern binding" pprMatchContextNoun PatBindGuards = text "pattern binding guards" pprMatchContextNoun LambdaExpr = text "lambda abstraction"-pprMatchContextNoun ProcExpr = text "arrow abstraction"+pprMatchContextNoun (ArrowMatchCtxt c)= pprArrowMatchContextNoun c pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration"++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"+pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction" ----------------- pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20211001+version: 0.20211101 license: BSD3 license-file: LICENSE category: Development@@ -69,21 +69,21 @@ else build-depends: Win32 build-depends:- ghc-prim > 0.2 && < 0.8, base >= 4.14 && < 4.17,+ ghc-prim > 0.2 && < 0.9,+ bytestring >= 0.9 && < 0.12,+ time >= 1.4 && < 1.12,+ exceptions == 0.10.*,+ parsec, containers >= 0.5 && < 0.7,- bytestring >= 0.9 && < 0.11, binary == 0.8.*, filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.5, pretty == 1.1.*,- time >= 1.4 && < 1.10, transformers == 0.5.*,- process >= 1 && < 1.7,- exceptions == 0.10.*,- parsec+ process >= 1 && < 1.7 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -231,7 +231,6 @@ GHC.Driver.CmdLine GHC.Driver.Config GHC.Driver.Config.Diagnostic- GHC.Driver.Config.Finder GHC.Driver.Config.Logger GHC.Driver.Config.Parser GHC.Driver.Env@@ -348,6 +347,7 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic+ GHC.Types.BreakInfo GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State@@ -375,6 +375,7 @@ GHC.Types.Name.Ppr GHC.Types.Name.Reader GHC.Types.Name.Set+ GHC.Types.PkgQual GHC.Types.RepType GHC.Types.SafeHaskell GHC.Types.SourceError@@ -401,7 +402,6 @@ GHC.Unit.Database GHC.Unit.Env GHC.Unit.External- GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home GHC.Unit.Home.ModInfo
ghc-lib/stage0/compiler/build/GHC/Parser.hs view
@@ -72,6 +72,7 @@ import GHC.Types.ForeignCall import GHC.Types.SourceFile import GHC.Types.SourceText+import GHC.Types.PkgQual import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) import GHC.Core.Class ( FunDep )@@ -456,8 +457,8 @@ happyOut64 :: (HappyAbsSyn ) -> HappyWrap64 happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut64 #-}-newtype HappyWrap65 = HappyWrap65 ((Maybe EpaLocation,Maybe StringLiteral))-happyIn65 :: ((Maybe EpaLocation,Maybe StringLiteral)) -> (HappyAbsSyn )+newtype HappyWrap65 = HappyWrap65 ((Maybe EpaLocation, RawPkgQual))+happyIn65 :: ((Maybe EpaLocation, RawPkgQual)) -> (HappyAbsSyn ) happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x) {-# INLINE happyIn65 #-} happyOut65 :: (HappyAbsSyn ) -> HappyWrap65@@ -470,8 +471,8 @@ happyOut66 :: (HappyAbsSyn ) -> HappyWrap66 happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut66 #-}-newtype HappyWrap67 = HappyWrap67 ((Maybe EpaLocation,Located (Maybe (Located ModuleName))))-happyIn67 :: ((Maybe EpaLocation,Located (Maybe (Located ModuleName)))) -> (HappyAbsSyn )+newtype HappyWrap67 = HappyWrap67 ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))))+happyIn67 :: ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName)))) -> (HappyAbsSyn ) happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x) {-# INLINE happyIn67 #-} happyOut67 :: (HappyAbsSyn ) -> HappyWrap67@@ -1771,8 +1772,8 @@ happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut249 #-}-newtype HappyWrap250 = HappyWrap250 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LStmt GhcPs (LocatedA b)])))-happyIn250 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+newtype HappyWrap250 = HappyWrap250 (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])))+happyIn250 :: (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) {-# INLINE happyIn250 #-} happyOut250 :: (HappyAbsSyn ) -> HappyWrap250@@ -2240,8 +2241,8 @@ happyOut316 :: (HappyAbsSyn ) -> HappyWrap316 happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut316 #-}-newtype HappyWrap317 = HappyWrap317 (Located ModuleName)-happyIn317 :: (Located ModuleName) -> (HappyAbsSyn )+newtype HappyWrap317 = HappyWrap317 (LocatedA ModuleName)+happyIn317 :: (LocatedA ModuleName) -> (HappyAbsSyn ) happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x) {-# INLINE happyIn317 #-} happyOut317 :: (HappyAbsSyn ) -> HappyWrap317@@ -3308,7 +3309,7 @@ = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> happyIn22- (sLL happy_var_1 happy_var_3 $ (happy_var_1, happy_var_3)+ (sLL (reLoc happy_var_1) happy_var_3 $ (reLoc happy_var_1, happy_var_3) )}} happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3323,7 +3324,7 @@ case happyOut317 happy_x_3 of { (HappyWrap317 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn22- (sLL happy_var_1 happy_var_4 $ (happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar happy_var_3)+ (sLL (reLoc happy_var_1) happy_var_4 $ (reLoc happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar (reLoc happy_var_3)) ) `HappyStk` happyRest}}}} happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3335,7 +3336,7 @@ case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn23- (sLL happy_var_1 happy_var_3 $ HsModuleVar happy_var_2+ (sLL happy_var_1 happy_var_3 $ HsModuleVar (reLoc happy_var_2) )}}} happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3346,7 +3347,7 @@ = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> case happyOut317 happy_x_3 of { (HappyWrap317 happy_var_3) -> happyIn23- (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 happy_var_3+ (sLL happy_var_1 (reLoc happy_var_3) $ HsModuleId happy_var_1 (reLoc happy_var_3) )}} happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3487,7 +3488,7 @@ = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> case happyOut317 happy_x_3 of { (HappyWrap317 happy_var_3) -> happyIn30- (sLL happy_var_1 happy_var_3 $ Renaming happy_var_1 (Just happy_var_3)+ (sLL (reLoc happy_var_1) (reLoc happy_var_3) $ Renaming (reLoc happy_var_1) (Just (reLoc happy_var_3)) )}} happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3495,7 +3496,7 @@ happyReduction_50 happy_x_1 = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> happyIn30- (sL1 happy_var_1 $ Renaming happy_var_1 Nothing+ (sL1 (reLoc happy_var_1) $ Renaming (reLoc happy_var_1) Nothing )} happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3567,7 +3568,7 @@ (case snd happy_var_2 of NotBoot -> HsSrcFile IsBoot -> HsBootFile)- happy_var_3+ (reLoc happy_var_3) (Just $ sL1 happy_var_1 (HsModule noAnn (thdOf3 happy_var_7) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7) happy_var_4 Nothing)) ) `HappyStk` happyRest}}}}}} @@ -3588,7 +3589,7 @@ happyIn33 (sL1 happy_var_1 $ DeclD HsigFile- happy_var_2+ (reLoc happy_var_2) (Just $ sL1 happy_var_1 (HsModule noAnn (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6) happy_var_3 Nothing)) ) `HappyStk` happyRest}}}}} @@ -3603,7 +3604,7 @@ happyIn33 (sL1 happy_var_1 $ DeclD (case snd happy_var_2 of NotBoot -> HsSrcFile- IsBoot -> HsBootFile) happy_var_3 Nothing+ IsBoot -> HsBootFile) (reLoc happy_var_3) Nothing )}}} happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3613,7 +3614,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> happyIn33- (sL1 happy_var_1 $ DeclD HsigFile happy_var_2 Nothing+ (sL1 happy_var_1 $ DeclD HsigFile (reLoc happy_var_2) Nothing )}} happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -3797,7 +3798,7 @@ = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> happyIn41- ((happy_var_1, happy_var_2)+ ((reverse happy_var_1, happy_var_2) )}} happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4039,7 +4040,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> - ( fmap (unitOL . reLocA) (acs (\cs -> sLL happy_var_1 happy_var_2 (IEModuleContents (EpAnn (glR happy_var_1) [mj AnnModule happy_var_1] cs) happy_var_2))))}})+ ( fmap (unitOL . reLocA) (acs (\cs -> sLL happy_var_1 (reLoc happy_var_2) (IEModuleContents (EpAnn (glR happy_var_1) [mj AnnModule happy_var_1] cs) happy_var_2))))}}) ) (\r -> happyReturn (happyIn51 r)) happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4220,7 +4221,7 @@ = happyThen ((case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { i <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3)+ ( do { i <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) ; return (i : happy_var_1)})}}}) ) (\r -> happyReturn (happyIn61 r)) @@ -4264,7 +4265,7 @@ , importDeclAnnPackage = fst happy_var_5 , importDeclAnnAs = fst happy_var_8 }- ; fmap reLocA $ acs (\cs -> L (comb5 happy_var_1 happy_var_6 happy_var_7 (snd happy_var_8) happy_var_9) $+ ; fmap reLocA $ acs (\cs -> L (comb5 happy_var_1 (reLoc happy_var_6) happy_var_7 (snd happy_var_8) happy_var_9) $ ImportDecl { ideclExt = EpAnn (glR happy_var_1) anns cs , ideclSourceSrc = snd $ fst happy_var_2 , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5@@ -4316,13 +4317,13 @@ ; unless (looksLikePackageName (unpackFS pkgFS)) $ addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ (PsErrInvalidPackageName pkgFS)- ; return (Just (glAA happy_var_1), Just (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })})+ ; return (Just (glAA happy_var_1), RawPkgQual (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })}) ) (\r -> happyReturn (happyIn65 r)) happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_124 = happySpecReduce_0 49# happyReduction_124 happyReduction_124 = happyIn65- ((Nothing,Nothing)+ ((Nothing,NoRawPkgQual) ) happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4347,7 +4348,7 @@ case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> happyIn67 ((Just (glAA happy_var_1)- ,sLL happy_var_1 happy_var_2 (Just happy_var_2))+ ,sLL happy_var_1 (reLoc happy_var_2) (Just happy_var_2)) )}} happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4483,7 +4484,7 @@ = happyThen ((case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3)+ ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) ; return (happy_var_1 `snocOL` t) })}}}) ) (\r -> happyReturn (happyIn74 r)) @@ -4512,7 +4513,7 @@ = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3)+ ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) ; return (happy_var_1 `snocOL` t) })}}}) ) (\r -> happyReturn (happyIn76 r)) @@ -5904,7 +5905,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut119 happy_x_3 of { (HappyWrap119 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLLlA happy_var_1 happy_var_3 ((mz AnnSemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) , unitOL happy_var_3)) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -5921,7 +5922,7 @@ = happyThen ((case happyOut120 happy_x_1 of { (HappyWrap120 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLL happy_var_1 happy_var_2 ((mz AnnSemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLL happy_var_1 happy_var_2 ( (fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) ,snd $ unLoc happy_var_1)) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -6012,7 +6013,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut123 happy_x_3 of { (HappyWrap123 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLL happy_var_1 happy_var_3 ((mz AnnSemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) , unLoc happy_var_3)) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -6029,7 +6030,7 @@ = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLL happy_var_1 happy_var_2 ((mz AnnSemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) ,snd $ unLoc happy_var_1)) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -6101,7 +6102,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut198 happy_x_3 of { (HappyWrap198 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLLlA happy_var_1 happy_var_3 ((msemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (msemi happy_var_2) , unitOL happy_var_3)) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -6121,7 +6122,7 @@ = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1)- then return (sLL happy_var_1 happy_var_2 (((msemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ then return (sLL happy_var_1 happy_var_2 (((fst $ unLoc happy_var_1) ++ (msemi happy_var_2) ,snd $ unLoc happy_var_1))) else case (snd $ unLoc happy_var_1) of SnocOL hs t -> do@@ -9920,7 +9921,7 @@ case happyOut237 happy_x_2 of { (HappyWrap237 happy_var_2) -> happyIn237 (happy_var_2 >>= \ happy_var_2 -> return $- sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2))+ sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2) ) ,snd $ unLoc happy_var_2) )}} @@ -9936,7 +9937,7 @@ (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ happy_var_3 -> case snd $ unLoc happy_var_1 of- [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((mz AnnSemi happy_var_2) ++(fst $ unLoc happy_var_1)+ [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) ,[happy_var_3])) (h:t) -> do h' <- addTrailingSemiA h (gl happy_var_2)@@ -9952,7 +9953,7 @@ happyIn238 (happy_var_1 >>= \ happy_var_1 -> case snd $ unLoc happy_var_1 of- [] -> return (sLL happy_var_1 happy_var_2 ((mz AnnSemi happy_var_2) ++(fst $ unLoc happy_var_1)+ [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) ,[])) (h:t) -> do h' <- addTrailingSemiA h (gl happy_var_2)@@ -10125,7 +10126,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> happyIn249 (happy_var_2 >>= \ happy_var_2 -> amsrl- (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) [])+ (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fromOL $ fst $ unLoc happy_var_2) []) )}}} happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10136,7 +10137,7 @@ = case happyOut250 happy_x_2 of { (HappyWrap250 happy_var_2) -> happyIn249 (happy_var_2 >>= \ happy_var_2 -> amsrl- (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) [])+ (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing (fromOL $ fst $ unLoc happy_var_2) []) )} happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10151,7 +10152,7 @@ (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) -> case (snd $ unLoc happy_var_1) of- [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((mj AnnSemi happy_var_2) : (fst $ unLoc happy_var_1)+ [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2) ,happy_var_3 : (snd $ unLoc happy_var_1))) (h:t) -> do { h' <- addTrailingSemiA h (gl happy_var_2)@@ -10167,7 +10168,7 @@ happyIn250 (happy_var_1 >>= \ happy_var_1 -> case (snd $ unLoc happy_var_1) of- [] -> return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2) : (fst $ unLoc happy_var_1),snd $ unLoc happy_var_1))+ [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2),snd $ unLoc happy_var_1)) (h:t) -> do { h' <- addTrailingSemiA h (gl happy_var_2) ; return $ sL1 happy_var_1 (fst $ unLoc happy_var_1,h':t) }@@ -10179,13 +10180,13 @@ = case happyOut253 happy_x_1 of { (HappyWrap253 happy_var_1) -> happyIn250 (happy_var_1 >>= \ happy_var_1 ->- return $ sL1A happy_var_1 ([],[happy_var_1])+ return $ sL1A happy_var_1 (nilOL,[happy_var_1]) )} happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_632 = happySpecReduce_0 234# happyReduction_632 happyReduction_632 = happyIn250- (return $ noLoc ([],[])+ (return $ noLoc (nilOL,[]) ) happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -11823,7 +11824,7 @@ happyReduction_806 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317- (sL1 happy_var_1 $ mkModuleNameFS (getCONID happy_var_1)+ (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) )} happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -11831,7 +11832,7 @@ happyReduction_807 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317- (sL1 happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in+ (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in mkModuleNameFS (mkFastString (unpackFS mod ++ '.':unpackFS c))@@ -12616,11 +12617,11 @@ listAsAnchor (L l _:_) = spanAsAnchor (locA l) hsTok :: Located Token -> LHsToken tok GhcPs-hsTok (L l _) = L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments) HsTok+hsTok (L l _) = L (mkTokenLocation l) HsTok hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs hsUniTok t@(L l _) =- L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments)+ L (mkTokenLocation l) (if isUnicode t then HsUnicodeTok else HsNormalTok) -- -------------------------------------
ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs view
@@ -3404,12 +3404,11 @@ -} --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate -- 'AddEpAnn' values for the opening and closing bordering on the start -- and end of the span-mkParensEpAnn :: SrcSpan -> [AddEpAnn]-mkParensEpAnn (UnhelpfulSpan _) = []-mkParensEpAnn (RealSrcSpan ss _) = [AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc)]+mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc)) where f = srcSpanFile ss sl = srcSpanStartLine ss
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -97,7 +97,7 @@ /* Define to 1 if you have the <bfd.h> header file. */ /* #undef HAVE_BFD_H */ -/* Does GCC support __atomic primitives? */+/* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 /* Define to 1 if you have the `clock_gettime' function. */@@ -377,6 +377,9 @@ /* Define to 1 if C symbols have a leading underscore added by the compiler. */ #define LEADING_UNDERSCORE 1++/* Define to 1 if we need -latomic for sub-word atomic operations. */+#define NEED_ATOMIC_LIB 0 /* Define 1 if we need to link code using pthreads with -lpthread */ #define NEED_PTHREAD_LIB 0
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "ef92a0095cee1f623fba1c285c1836e80bf16223"+cProjectGitCommitId = "7445bd714c1bea39207f9a2fa497c325b95ba2c7" cProjectVersion :: String-cProjectVersion = "9.3.20210930"+cProjectVersion = "9.3.20211101" cProjectVersionInt :: String cProjectVersionInt = "903" cProjectPatchLevel :: String-cProjectPatchLevel = "20210930"+cProjectPatchLevel = "20211101" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "20210930"+cProjectPatchLevel1 = "20211101" cProjectPatchLevel2 :: String cProjectPatchLevel2 = ""
libraries/ghc-boot/GHC/Unit/Database.hs view
@@ -99,7 +99,7 @@ import System.Directory -- | @ghc-boot@'s UnitInfo, serialized to the database.-type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule+type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule -- | Information about an unit (a unit is an installed module library). --@@ -109,14 +109,16 @@ -- Some types are left as parameters to be instantiated differently in ghc-pkg -- and in ghc itself. ---data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo+data GenericUnitInfo srcpkgid srcpkgname uid modulename mod = GenericUnitInfo { unitId :: uid -- ^ Unique unit identifier that is used during compilation (e.g. to -- generate symbols). - , unitInstanceOf :: compid+ , unitInstanceOf :: uid -- ^ Identifier of an indefinite unit (i.e. with module holes) that this -- unit is an instance of.+ --+ -- For non instantiated units, unitInstanceOf=unitId , unitInstantiations :: [(modulename, mod)] -- ^ How this unit instantiates some of its module holes. Map hole module@@ -252,16 +254,15 @@ -- | Convert between GenericUnitInfo instances mapGenericUnitInfo :: (uid1 -> uid2)- -> (cid1 -> cid2) -> (srcpkg1 -> srcpkg2) -> (srcpkgname1 -> srcpkgname2) -> (modname1 -> modname2) -> (mod1 -> mod2)- -> (GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1- -> GenericUnitInfo cid2 srcpkg2 srcpkgname2 uid2 modname2 mod2)-mapGenericUnitInfo fuid fcid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) =+ -> (GenericUnitInfo srcpkg1 srcpkgname1 uid1 modname1 mod1+ -> GenericUnitInfo srcpkg2 srcpkgname2 uid2 modname2 mod2)+mapGenericUnitInfo fuid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) = g { unitId = fuid unitId- , unitInstanceOf = fcid unitInstanceOf+ , unitInstanceOf = fuid unitInstanceOf , unitInstantiations = fmap (bimap fmodname fmod) unitInstantiations , unitPackageId = fsrcpkg unitPackageId , unitPackageName = fsrcpkgname unitPackageName@@ -711,7 +712,7 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option).-mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f+mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e -> GenericUnitInfo a b c d e mungeUnitInfoPaths top_dir pkgroot pkg = -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs pkg
libraries/ghci/GHCi/Message.hs view
@@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 3 || \- (major1) == 9 && (major2) == 3 && (minor) <= 20210930)+ (major1) == 9 && (major2) == 3 && (minor) <= 20211101) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo