diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -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 diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -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. diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -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] {- ********************************************************************* * * diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs --- a/compiler/GHC/Builtin/Uniques.hs +++ b/compiler/GHC/Builtin/Uniques.hs @@ -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 -------------------------------------------------- diff --git a/compiler/GHC/Builtin/Uniques.hs-boot b/compiler/GHC/Builtin/Uniques.hs-boot --- a/compiler/GHC/Builtin/Uniques.hs-boot +++ b/compiler/GHC/Builtin/Uniques.hs-boot @@ -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 diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -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 diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -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) diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -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 {- ************************************************************************ diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -174,7 +174,7 @@ let a = Type Bool in let x::a = True in That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". -One place it is used is in 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 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 diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -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 ) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -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: diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -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 } diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -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 diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -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 diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -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 diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -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 diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -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 diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -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} diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -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] +-} diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -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 diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,7 +23,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 diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -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 diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -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)) diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -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 diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs --- a/compiler/GHC/Data/List/SetOps.hs +++ b/compiler/GHC/Data/List/SetOps.hs @@ -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 _ [] = [] diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -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 diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -39,7 +39,7 @@ data HsComponentId = HsComponentId { hsPackageName :: PackageName, - hsComponentId :: IndefUnitId + hsComponentId :: UnitId } instance Outputable HsComponentId where diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs deleted file mode 100644 --- a/compiler/GHC/Driver/Config/Finder.hs +++ /dev/null @@ -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 - } diff --git a/compiler/GHC/Driver/Env/KnotVars.hs b/compiler/GHC/Driver/Env/KnotVars.hs --- a/compiler/GHC/Driver/Env/KnotVars.hs +++ b/compiler/GHC/Driver/Env/KnotVars.hs @@ -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 -} diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -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 ] - diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -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 diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -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 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -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\@ flags can all be reversed with @-Wno-\@ 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 @-\@ flags can all be reversed with @-no-\@ @@ -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 diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -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]), diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -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 diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -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" diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -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 diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -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. diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -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) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -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) diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -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] diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -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'. diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -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 }) = [] diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -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 diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -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. -- diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -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 diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -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] diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -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. diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -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, diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -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 diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -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 diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -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 } diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -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 - diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -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 { diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -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 diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -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 diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -2,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) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -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 " $ diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs --- a/compiler/GHC/Tc/Solver/Types.hs +++ b/compiler/GHC/Tc/Solver/Types.hs @@ -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 diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -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. + } {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -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 diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -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)] diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -2,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 diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -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 "" + 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 + } diff --git a/compiler/GHC/Types/BreakInfo.hs b/compiler/GHC/Types/BreakInfo.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/BreakInfo.hs @@ -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 + } diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -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) = `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) = `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 + | 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 diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -41,6 +41,7 @@ , suggestExtensionsWithInfo , suggestAnyExtension , suggestAnyExtensionWithInfo + , useExtensionInOrderTo , noHints -- * Rendering Messages diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -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 diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -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" diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -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 diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -83,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 diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -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) diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -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) diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -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 diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -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 {- ************************************************************************ diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -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] diff --git a/compiler/GHC/Types/PkgQual.hs b/compiler/GHC/Types/PkgQual.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/PkgQual.hs @@ -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) + + diff --git a/compiler/GHC/Types/Target.hs b/compiler/GHC/Types/Target.hs --- a/compiler/GHC/Types/Target.hs +++ b/compiler/GHC/Types/Target.hs @@ -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 diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -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 diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -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 diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -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 diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -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 diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs --- a/compiler/GHC/Unit.hs +++ b/compiler/GHC/Unit.hs @@ -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] diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs deleted file mode 100644 --- a/compiler/GHC/Unit/Finder.hs +++ /dev/null @@ -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) - diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs --- a/compiler/GHC/Unit/Finder/Types.hs +++ b/compiler/GHC/Unit/Finder/Types.hs @@ -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 + } diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -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 diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs --- a/compiler/GHC/Unit/Home/ModInfo.hs +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -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 diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -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 diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -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" diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -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, diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -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 diff --git a/compiler/GHC/Unit/Module/Location.hs b/compiler/GHC/Unit/Module/Location.hs --- a/compiler/GHC/Unit/Module/Location.hs +++ b/compiler/GHC/Unit/Module/Location.hs @@ -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) + } diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -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: -- diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs --- a/compiler/GHC/Unit/Module/ModSummary.hs +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -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 diff --git a/compiler/GHC/Unit/Parser.hs b/compiler/GHC/Unit/Parser.hs --- a/compiler/GHC/Unit/Parser.hs +++ b/compiler/GHC/Unit/Parser.hs @@ -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 diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -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). diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -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=,A=aimpl:A>]@ (@p@ is the 'IndefUnitId', and the +-- @p[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) diff --git a/compiler/GHC/Unit/Types.hs-boot b/compiler/GHC/Unit/Types.hs-boot --- a/compiler/GHC/Unit/Types.hs-boot +++ b/compiler/GHC/Unit/Types.hs-boot @@ -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 diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -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 diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -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' diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -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) diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/GHC/Parser.hs b/ghc-lib/stage0/compiler/build/GHC/Parser.hs --- a/ghc-lib/stage0/compiler/build/GHC/Parser.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Parser.hs @@ -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) -- ------------------------------------- diff --git a/ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs b/ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs --- a/ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs @@ -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 diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -97,7 +97,7 @@ /* Define to 1 if you have the 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 diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "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 = "" diff --git a/libraries/ghc-boot/GHC/Unit/Database.hs b/libraries/ghc-boot/GHC/Unit/Database.hs --- a/libraries/ghc-boot/GHC/Unit/Database.hs +++ b/libraries/ghc-boot/GHC/Unit/Database.hs @@ -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 diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -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