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 @@ -276,7 +276,7 @@ -- Dynamic toDynName, - -- GHC.Internal.Numeric stuff + -- Numeric stuff negateName, minusName, geName, eqName, mkRationalBase2Name, mkRationalBase10Name, @@ -430,7 +430,6 @@ naturalPowModName, naturalSizeInBaseName, - bignatFromWordListName, bignatEqName, -- Float/Double @@ -1203,7 +1202,6 @@ , naturalLogBaseName , naturalPowModName , naturalSizeInBaseName - , bignatFromWordListName , bignatEqName , bignatCompareName , bignatCompareWordName @@ -1215,7 +1213,6 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key -- Types and DataCons -bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey @@ -2010,6 +2007,12 @@ unsatisfiableClassNameKey :: Unique unsatisfiableClassNameKey = mkPreludeTyConUnique 170 +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 171 + +zonkAnyTyConKey :: Unique +zonkAnyTyConKey = mkPreludeTyConUnique 172 + -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 @@ -2023,9 +2026,6 @@ specTyConKey :: Unique specTyConKey = mkPreludeTyConUnique 185 -anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 186 - smallArrayPrimTyConKey = mkPreludeTyConUnique 187 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 @@ -2641,7 +2641,6 @@ , naturalLogBaseIdKey , naturalPowModIdKey , naturalSizeInBaseIdKey - , bignatFromWordListIdKey , bignatEqIdKey , bignatCompareIdKey , bignatCompareWordIdKey @@ -2709,7 +2708,6 @@ naturalPowModIdKey = mkPreludeMiscIdUnique 683 naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 -bignatFromWordListIdKey = mkPreludeMiscIdUnique 690 bignatEqIdKey = mkPreludeMiscIdUnique 691 bignatCompareIdKey = mkPreludeMiscIdUnique 692 bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 diff --git a/compiler/GHC/Builtin/PrimOps.hs-boot b/compiler/GHC/Builtin/PrimOps.hs-boot --- a/compiler/GHC/Builtin/PrimOps.hs-boot +++ b/compiler/GHC/Builtin/PrimOps.hs-boot @@ -1,5 +1,6 @@ module GHC.Builtin.PrimOps where -import GHC.Prelude () +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () data PrimOp diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -78,6 +78,7 @@ promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, soloTyCon, + soloDataConName, pairTyCon, mkPromotedPairTy, isPromotedPairType, unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, @@ -91,7 +92,7 @@ cTupleSelId, cTupleSelIdName, -- * Any - anyTyCon, anyTy, anyTypeOfKind, + anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon, -- * Recovery TyCon makeRecoveryTyCon, @@ -184,7 +185,7 @@ import GHC.Core.TyCon import GHC.Core.Class ( Class, mkClass ) import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) -import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) +import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) ) import GHC.Types.TyThing import GHC.Types.SourceText @@ -309,6 +310,7 @@ , soloTyCon , anyTyCon + , zonkAnyTyCon , boolTyCon , charTyCon , stringTyCon @@ -419,58 +421,107 @@ {- Note [Any types] ~~~~~~~~~~~~~~~~ -The type constructor Any, +The type constructors `Any` and `ZonkAny` are closed type families declared thus: - type family Any :: k where { } + type family Any :: forall k. k where { } + type family ZonkAny :: forall k. Nat -> k where { } -It has these properties: +They are used when we want a type of a particular kind, but we don't really care +what that type is. The leading example is this: `ZonkAny` is used to instantiate +un-constrained type variables after type checking. For example, consider the +term (length [] :: Int), where - * Note that 'Any' is kind polymorphic since in some program we may - need to use Any to fill in a type variable of some kind other than * - (see #959 for examples). Its kind is thus `forall k. k``. + length :: forall a. [a] -> Int + [] :: forall a. [a] - * It is defined in module GHC.Types, and exported so that it is - available to users. For this reason it's treated like any other - wired-in type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache +We must type-apply `length` and `[]`, but to what type? It doesn't matter! +The typechecker will end up with - * It is a *closed* type family, with no instances. This means that - if ty :: '(k1, k2) we add a given coercion - g :: ty ~ (Fst ty, Snd ty) - If Any was a *data* type, then we'd get inconsistency because 'ty' - could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other. See also #9097 and #9636. + length @alpha ([] @alpha) - * When instantiated at a lifted type it is inhabited by at least one value, - namely bottom +where `alpha` is an un-constrained unification variable. The "zonking" process zaps +that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is +arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`. +So we end up with - * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3)) - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. +`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see +wrinkle (Any4). - * It is wired-in so we can easily refer to it where we don't have a name - environment (e.g. see Rules.matchRule for one example) +Wrinkles: -It's used to instantiate un-constrained type variables after type checking. For -example, 'length' has type +(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may + need to use `ZonkAny` to fill in a type variable of some kind other than * + (see #959 for examples). - length :: forall a. [a] -> Int +(Any2) They are /closed/ type families, with no instances. For example, suppose that + with alpha :: '(k1, k2) we add a given coercion + g :: alpha ~ (Fst alpha, Snd alpha) + and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type, + we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one + side and '(,) on the other. See also #9097 and #9636. -and the list datacon for the empty list has type + See #25244 for a suggestion that we instead use an /open/ type family for which + you cannot provide instances. Probably the difference is not very important. - [] :: forall a. [a] +(Any3) They do not claim to be /data/ types, and that's important for + the code generator, because the code gen may /enter/ a data value + but never enters a function value. -In order to compose these two terms as @length []@ a type -application is required, but there is no constraint on the -choice. In this situation GHC uses 'Any', +(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/ + types (#24817). Consider -> length @(Any @Type) ([] @(Any @Type)) + data SBool a where { STrue :: SBool True; SFalse :: SBool False } -Above, we print kinds explicitly, as if with -fprint-explicit-kinds. + foo :: forall a b. (SBool a, SBool b) + bar :: Bool + bar = case foo @alpha @beta of + (STrue, SFalse) -> True -- This branch is not inaccessible! + _ -> False + + Now, what are `alpha` and `beta`? If we zonk both of them to the same type + `Any @Type`, the pattern-match checker will (wrongly) report that the first + branch is inaccessible. So we zonk them to two /different/ types: + alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5 + (The actual numbers are arbitrary; they just need to differ.) + + The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and + `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to + make up a fresh type. + + If this example seems unconvincing (e.g. in this case foo must be bottom) + see #24817 for larger but more compelling examples. + +(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we + don't have a name environment (e.g. see Rules.matchRule for one example) + +(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that + it is available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + Currently `ZonkAny` is not available to users; but it could easily be. + +(Any7) Properties of `Any`: + * When `Any` is instantiated at a lifted type it is inhabited by at least one value, + namely bottom. + + * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`. + + * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`. + + * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when + the kinds of both the type and `Any` match. + + * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over + `unsafeCoerce#` as they prevent accidentally coercing between types with kinds + that don't match. + + See examples in ghc-prim:GHC.Types + The Any tycon used to be quite magic, but we have since been able to implement it merely with an empty kind polymorphic type family. See #10886 for a bit of history. @@ -482,6 +533,7 @@ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon anyTyCon :: TyCon +-- See Note [Any types] anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing (ClosedSynFamilyTyCon Nothing) Nothing @@ -496,6 +548,24 @@ anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkTyConApp anyTyCon [kind] +zonkAnyTyConName :: Name +zonkAnyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon + +zonkAnyTyCon :: TyCon +-- ZonkAnyTyCon :: forall k. Nat -> k +-- See Note [Any types] +zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName + [ mkNamedTyConBinder Specified kv + , mkAnonTyConBinder nat_kv ] + (mkTyVarTy kv) + Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy] + -- | Make a fake, recovery 'TyCon' from an existing one. -- Used when recovering from errors in type declarations makeRecoveryTyCon :: TyCon -> TyCon @@ -827,7 +897,6 @@ ":" -> Just consDataConName -- function tycon - "FUN" -> Just fUNTyConName "->" -> Just unrestrictedFunTyConName -- tuple data/tycon @@ -986,40 +1055,36 @@ isCTupleOcc_maybe mod occ <|> isSumTyOcc_maybe mod occ -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName --- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ns ar) -mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ns ar) +mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax) +mkTupleOcc ns b ar = (mkOccName ns str, built_in) + where (str, built_in) = mkTupleStr' ns b ar mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) mkTupleStr :: Boxity -> NameSpace -> Arity -> String -mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = mkUnboxedTupleStr - -mkBoxedTupleStr :: NameSpace -> Arity -> String -mkBoxedTupleStr ns 0 - | isDataConNameSpace ns = "()" - | otherwise = "Unit" -mkBoxedTupleStr ns 1 - | isDataConNameSpace ns = "MkSolo" -- See Note [One-tuples] - | otherwise = "Solo" -mkBoxedTupleStr ns ar - | isDataConNameSpace ns = '(' : commas ar ++ ")" - | otherwise = "Tuple" ++ showInt ar "" - +mkTupleStr b ns ar = str + where (str, _) = mkTupleStr' ns b ar -mkUnboxedTupleStr :: NameSpace -> Arity -> String -mkUnboxedTupleStr ns 0 - | isDataConNameSpace ns = "(##)" - | otherwise = "Unit#" -mkUnboxedTupleStr ns 1 - | isDataConNameSpace ns = "(# #)" -- See Note [One-tuples] - | otherwise = "Solo#" -mkUnboxedTupleStr ns ar - | isDataConNameSpace ns = "(#" ++ commas ar ++ "#)" - | otherwise = "Tuple" ++ show ar ++ "#" +mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax) +mkTupleStr' ns Boxed 0 + | isDataConNameSpace ns = ("()", BuiltInSyntax) + | otherwise = ("Unit", UserSyntax) +mkTupleStr' ns Boxed 1 + | isDataConNameSpace ns = ("MkSolo", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo", UserSyntax) +mkTupleStr' ns Boxed ar + | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax) + | otherwise = ("Tuple" ++ showInt ar "", UserSyntax) +mkTupleStr' ns Unboxed 0 + | isDataConNameSpace ns = ("(##)", BuiltInSyntax) + | otherwise = ("Unit#", UserSyntax) +mkTupleStr' ns Unboxed 1 + | isDataConNameSpace ns = ("(# #)", BuiltInSyntax) -- See Note [One-tuples] + | otherwise = ("Solo#", UserSyntax) +mkTupleStr' ns Unboxed ar + | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax) + | otherwise = ("Tuple" ++ show ar ++ "#", UserSyntax) mkConstraintTupleStr :: Arity -> String mkConstraintTupleStr 0 = "CUnit" @@ -1175,10 +1240,10 @@ boxity = Boxed modu = gHC_INTERNAL_TUPLE - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) UserSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity @@ -1209,10 +1274,10 @@ boxity = Unboxed modu = gHC_TYPES - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) UserSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity @@ -1275,6 +1340,9 @@ soloTyConName :: Name soloTyConName = tyConName soloTyCon + +soloDataConName :: Name +soloDataConName = tupleDataConName Boxed 1 pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 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 @@ -63,7 +63,8 @@ doublePrimTyCon, doublePrimTy, doublePrimTyConName, statePrimTyCon, mkStatePrimTy, - realWorldTyCon, realWorldTy, realWorldStatePrimTy, + realWorldTyCon, realWorldTy, + realWorldStatePrimTy, realWorldMutableByteArrayPrimTy, proxyPrimTyCon, mkProxyPrimTy, @@ -1178,7 +1179,9 @@ realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld - +realWorldMutableByteArrayPrimTy :: Type +realWorldMutableByteArrayPrimTy + = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedNewtypes #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -8,6 +10,7 @@ -- | Bytecode assembler types module GHC.ByteCode.Types ( CompiledByteCode(..), seqCompiledByteCode + , BCOByteArray(..), mkBCOByteArray , FFIInfo(..) , RegBitmap(..) , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo @@ -18,12 +21,13 @@ , CgBreakInfo(..) , ModBreaks (..), BreakIndex, emptyModBreaks , CCostCentre + , FlatBag, sizeFlatBag, fromSizedSeq, elemsFlatBag ) where import GHC.Prelude import GHC.Data.FastString -import GHC.Data.SizedSeq +import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable @@ -33,10 +37,10 @@ import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq +import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray ) import Foreign import Data.Array -import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -152,10 +156,10 @@ = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap - unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs } instance NFData UnlinkedBCO where @@ -210,8 +214,8 @@ instance Outputable UnlinkedBCO where ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] + ppr (sizeFlatBag lits), text "lits", + ppr (sizeFlatBag ptrs), text "ptrs" ] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -228,7 +228,7 @@ andEq TEQX e = hasCast e andEq TEQ e = e - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type + -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 [])) | tc1 == tc2 = TEQ 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 @@ -860,7 +860,7 @@ -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work -exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType +exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y -- Nothing if the expression has arity 0 @@ -2359,8 +2359,8 @@ (mkNomReflCo (varType tcv)) co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has - -- a ForAllTyFlag of coreTyLamForAllTyFlag; see wrinkle (FC4) in - -- Note [ForAllCo] in GHC.Core.TyCo.Rep + -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep {- ************************************************************************ 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 @@ -2660,6 +2660,10 @@ inline f_ty (f a b c) = a b c (if f has an unfolding, EVEN if it's a loop breaker) + Additionally the rule looks through ticks/casts as well (#24808): + inline f_ty (f a b c |> co) = a b c |> co + inline f_ty ( f a b c ) = a b c + It's important to allow the argument to 'inline' to have args itself (a) because its more forgiving to allow the programmer to write either inline f a b c @@ -2672,11 +2676,17 @@ -} match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) +match_inline (Type _ : e : _) = go e + -- Maybe Monad ahead: + where + go (Var f) = -- Ignore the IdUnfoldingFun here! + (maybeUnfoldingTemplate (realIdUnfolding f)) + go (App f a) = do { f' <- go f; pure $ App f' a } + -- inline (f |> co) + go (Cast e co) = do { app <- go e; pure (Cast app co) } + -- inline ( f) + go (Tick t e) = do { app <- go e; pure (Tick t app) } + go _ = Nothing match_inline _ = Nothing diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -1035,8 +1035,6 @@ | otherwise = (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs ) where - is_join_point = isJoinPoint mb_join - --------- Right hand side --------- -- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have -- join j = Just (f x) in ... @@ -1044,12 +1042,9 @@ -- let y = f x in join j = Just y in ... -- That's that OccRhs would do; but there's no point because -- j will never be scrutinised. - env1 | is_join_point = setTailCtxt env - | otherwise = setNonTailCtxt rhs_ctxt env -- Zap occ_join_points + rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs rhs_ctxt = mkNonRecRhsCtxt bndr unf - -- See Note [Sources of one-shot information] - rhs_env = addOneShotsFromDmd bndr env1 -- See Note [Join arity prediction based on joinRhsArity] -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; @@ -1059,16 +1054,15 @@ final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] | otherwise = bndr `setIdSpecialisation` mkRuleInfo rules' - `setIdUnfolding` unf2 + `setIdUnfolding` unf1 final_bndr_no_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] - | otherwise = bndr `setIdUnfolding` unf2 + | otherwise = bndr `setIdUnfolding` unf1 --------- Unfolding --------- -- See Note [Join points and unfoldings/rules] unf = idUnfolding bndr WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf - unf2 = markNonRecUnfoldingOneShots mb_join unf1 adj_unf_uds = adjustTailArity mb_join unf_tuds --------- Rules --------- @@ -1142,10 +1136,8 @@ | isDeadOcc occ -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise - = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr + = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds - !unf' = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr) - !bndr' = tagged_bndr `setIdUnfolding` unf' in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -1750,10 +1742,9 @@ -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage -- until occAnalRec. In effect, we pretend that the RHS becomes a -- non-recursive join point and fix up later with adjustTailUsage. - rhs_env | isJoinId bndr = setTailCtxt env - | otherwise = setNonTailCtxt OccRhs env - -- If bndr isn't an /existing/ join point, it's safe to zap the - -- occ_join_points, because they can't occur in RHS. + rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs + -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint), + -- it's safe to zap the occ_join_points, because they can't occur in RHS. WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders @@ -2167,7 +2158,7 @@ in WTUD (TUD (joinRhsArity expr) usage) expr' occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr --- Does not markInsidLam etc for the outmost batch of lambdas +-- Does not markInsideLam etc for the outmost batch of lambdas occ_anal_lam_tail env expr@(Lam {}) = go env [] expr where @@ -2308,20 +2299,8 @@ occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails) -{- Note [Join point RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = e - join j = Just x - -We want to inline x into j right away, so we don't want to give -the join point a RhsCtxt (#14137). It's not a huge deal, because -the FloatIn pass knows to float into join point RHSs; and the simplifier -does not float things out of join point RHSs. But it's a simple, cheap -thing to do. See #14137. - -Note [Occurrences in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Occurrences in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f p = BIG {-# INLINE g #-} @@ -2357,17 +2336,33 @@ empty. This just saves a bit of allocation and reconstruction; not a big deal. -This fast path exposes a tricky cornder, though (#22761). Supose we have +Two tricky corners: + +* Dead bindings (#22761). Supose we have Unfolding = \x. let y = foo in x+1 -which includes a dead binding for `y`. In occAnalUnfolding we occ-anal -the unfolding and produce /no/ occurrences of `foo` (since `y` is -dead). But if we discard the occ-analysed syntax tree (which we do on -our fast path), and use the old one, we still /have/ an occurrence of -`foo` -- and that can lead to out-of-scope variables (#22761). + which includes a dead binding for `y`. In occAnalUnfolding we occ-anal + the unfolding and produce /no/ occurrences of `foo` (since `y` is + dead). But if we discard the occ-analysed syntax tree (which we do on + our fast path), and use the old one, we still /have/ an occurrence of + `foo` -- and that can lead to out-of-scope variables (#22761). -Solution: always keep occ-analysed trees in unfoldings and rules, so they -have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. + Solution: always keep occ-analysed trees in unfoldings and rules, so they + have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. +* One-shot binders. Consider + {- f has Stable unfolding \p q -> blah + Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -} + f = \x y. blah + + Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has + occ_one_shots = [NoOneShortInfo, OneShotLam] + This will put OneShotLam on the \y. And it'll put it on the \q. But the + noBinderSwap check will mean that we discard this new occ-anal'd unfolding + and keep the old one, with no OneShotInfo. + + This looks a little inconsistent, but the Stable unfolding is just used for + inlinings; OneShotInfo isn't a lot of use here. + Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an OccRhs for the RHS of a binding. This tells the @@ -2592,7 +2587,7 @@ | otherwise = case one_shots of [] -> (env_args, []) -- Fast path; one_shots is often empty - (os : one_shots') -> (addOneShots os env_args, one_shots') + (os : one_shots') -> (setOneShots os env_args, one_shots') {- Applications are dealt with specially because we want @@ -2888,42 +2883,125 @@ -- non-default alternative. That in turn influences -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! +{- Note [The OccEnv for a right hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we create the OccEnv for a RHS (in mkRhsOccEnv)? + +For a non-join point binding, x = rhs + + * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles + + * occ_join_points: zap them! + + * occ_one_shots: initialise from the idDemandInfo; + see Note [Sources of one-shot information] + +For a join point binding, j x = rhs + + * occ_encl: Consider + x = e + join j = Just x + We want to inline x into j right away, so we don't want to give the join point + a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the + FloatIn pass knows to float into join point RHSs; and the simplifier does not + float things out of join point RHSs. But it's a simple, cheap thing to do. + + * occ_join_points: no need to zap. + + * occ_one_shots: we start with one-shot-info from the context, which indeed + applies to the /body/ of the join point, after walking past the binders. + So we add to the front a OneShotInfo for each value-binder of the join + point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point + binders caused #25096.) + + For the join point binders themselves, of a /non-recursive/ join point, + we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`. + + These one-shot infos then get attached to the binder by `occAnalLamTail`. +-} + setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv setNonTailCtxt ctxt !env = env { occ_encl = ctxt , occ_one_shots = [] - , occ_join_points = zapped_jp_env } - where - -- zapped_jp_env is basically just emptyVarEnv (hence zapped). See (W3) of - -- Note [Occurrence analysis for join points] Zapping improves efficiency, - -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and - -- then find an occurrence of jx anyway, you might lose those uds, and - -- that might mean we don't record all occurrencs, and that means we - -- duplicate a redex.... a very nasty bug (which I encountered!). Hence - -- this DEBUG code which doesn't remove jx from the envt; it just gives it - -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch - -- this bug before it does any damage. -#ifdef DEBUG - zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env) -#else - zapped_jp_env = emptyVarEnv -#endif + , occ_join_points = zapJoinPointInfo (occ_join_points env) } setTailCtxt :: OccEnv -> OccEnv -setTailCtxt !env - = env { occ_encl = OccVanilla } +setTailCtxt !env = env { occ_encl = OccVanilla } -- Preserve occ_one_shots, occ_join points -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt): - -- see Note [Join point RHSs] -addOneShots :: OneShots -> OccEnv -> OccEnv -addOneShots os !env +mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv +-- See Note [The OccEnv for a right hand side] +-- For a join point: +-- - Keep occ_one_shots, occ_joinPoints from the context +-- - But push enough OneShotInfo onto occ_one_shots to account +-- for the join-point value binders +-- - Set occ_encl to OccVanilla +-- For non-join points +-- - Zap occ_one_shots and occ_join_points +-- - Set occ_encl to specified OccEncl +mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points }) + is_rec encl jp_hood bndr rhs + | JoinPoint join_arity <- jp_hood + = env { occ_encl = OccVanilla + , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + , occ_join_points = ctxt_join_points } + + | otherwise + = env { occ_encl = encl + , occ_one_shots = argOneShots (idDemandInfo bndr) + -- argOneShots: see Note [Sources of one-shot information] + , occ_join_points = zapJoinPointInfo ctxt_join_points } + +zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo +-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped). +-- See (W3) of Note [Occurrence analysis for join points] +-- +-- Zapping improves efficiency, slightly, if you accidentally introduce a bug, +-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you +-- might lose those uds, and that might mean we don't record all occurrencs, and +-- that means we duplicate a redex.... a very nasty bug (which I encountered!). +-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it +-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this +-- bug before it does any damage. +#ifdef DEBUG +zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info +#else +zapJoinPointInfo _ = emptyVarEnv +#endif + +extendOneShotsForJoinPoint + :: RecFlag -> JoinArity -> CoreExpr + -> [OneShotInfo] -> [OneShotInfo] +-- Push enough OneShortInfos on the front of ctxt_one_shots +-- to account for the value lambdas of the join point +extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + = go join_arity rhs + where + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + -- But not so for recursive ones + os = case is_rec of + NonRecursive -> OneShotLam + Recursive -> NoOneShotInfo + + go 0 _ = ctxt_one_shots + go n (Lam b rhs) + | isId b = os : go (n-1) rhs + | otherwise = go (n-1) rhs + go _ _ = [] -- Not enough lambdas. This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + +setOneShots :: OneShots -> OccEnv -> OccEnv +setOneShots os !env | null os = env -- Fast path for common case | otherwise = env { occ_one_shots = os } -addOneShotsFromDmd :: Id -> OccEnv -> OccEnv -addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr)) - isRhsEnv :: OccEnv -> Bool isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of OccRhs -> True @@ -3705,17 +3783,10 @@ -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the -- AcyclicSCC case of occAnalRec. --- * It applies 'markNonRecJoinOneShots' to the RHS --- * and returns the adjusted rhs UsageDetails combined with the body usage +-- It returns the adjusted rhs UsageDetails combined with the body usage adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs) - = WUD rhs_uds' rhs' - where - --------- Marking (non-rec) join binders one-shot --------- - !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs - | otherwise = rhs + = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs - --------- Adjusting right-hand side usage --------- - rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds adjustTailUsage :: JoinPointHood -> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail @@ -3732,33 +3803,6 @@ adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage - -markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr --- For a /non-recursive/ join point we can mark all --- its join-lambda as one-shot; and it's a good idea to do so -markNonRecJoinOneShots join_arity rhs - = go join_arity rhs - where - go 0 rhs = rhs - go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b) - (go (n-1) rhs) - go _ rhs = rhs -- Not enough lambdas. This can legitimately happen. - -- e.g. let j = case ... in j True - -- This will become an arity-1 join point after the - -- simplifier has eta-expanded it; but it may not have - -- enough lambdas /yet/. (Lint checks that JoinIds do - -- have enough lambdas.) - -markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding --- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding -markNonRecUnfoldingOneShots mb_join_arity unf - | JoinPoint ja <- mb_join_arity - , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf - , isStableSource src - , let !tmpl' = markNonRecJoinOneShots ja tmpl - = unf{uf_tmpl=tmpl'} - | otherwise - = unf type IdWithOccInfo = Id diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -971,7 +971,7 @@ -- Demand info: Note [Setting the demand info] info3 | isEvaldUnfolding new_unf - = zapDemandInfo info2 `orElse` info2 + = lazifyDemandInfo info2 `orElse` info2 | otherwise = info2 @@ -2278,34 +2278,44 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey - , [ TyArg {}, TyArg {} ] <- rev_args - -- Do this even if (contIsStop cont) + , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args + -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] = do { let arg_env = arg_se `setInScopeFromE` env - ty' = contResultType cont + overall_res_ty = contResultType cont + -- hole_ty is the type of the current runRW# application + (outer_cont, new_runrw_res_ty, inner_cont) + | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont) + | otherwise = (cont, hole_ty, mkBoringStop hole_ty) + -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + -- If the argument is a literal lambda already, take a short cut - -- This isn't just efficiency; if we don't do this we get a beta-redex - -- every time, so the simplifier keeps doing more iterations. + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] ; arg' <- case arg of Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body cont + ; body' <- simplExprC env' body inner_cont ; return (Lam s' body') } -- Important: do not try to eta-expand this lambda -- See Note [No eta-expansion in runRW#] + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' - , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + , sc_env = env', sc_cont = inner_cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } - ; let rr' = getRuntimeRep ty' - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] - ; return (emptyFloats env, call') } + ; let rr' = getRuntimeRep new_runrw_res_ty + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] + ; rebuild env call' outer_cont } ---------- Simplify value arguments -------------------- rebuildCall env fun_info @@ -2318,7 +2328,8 @@ -- Strict arguments | isStrictArgInfo fun_info - , seCaseCase env + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty @@ -3136,7 +3147,9 @@ -------------------------------------------------- reallyRebuildCase env scrut case_bndr alts cont - | not (seCaseCase env) + | not (seCaseCase env) -- Only when case-of-case is on. + -- See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = do { case_expr <- simplAlts env scrut case_bndr alts (mkBoringStop (contHoleType cont)) ; rebuild env case_expr cont } diff --git a/compiler/GHC/Core/TyCo/Compare.hs b/compiler/GHC/Core/TyCo/Compare.hs --- a/compiler/GHC/Core/TyCo/Compare.hs +++ b/compiler/GHC/Core/TyCo/Compare.hs @@ -12,8 +12,9 @@ nonDetCmpTypesX, nonDetCmpTc, eqVarBndrs, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTyConApps, + mayLookIdentical, -- * Visiblity comparision eqForAllVis, cmpForAllVis @@ -22,7 +23,8 @@ import GHC.Prelude -import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe ) +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe + , isLevityTy, isRuntimeRepTy, isMultiplicityTy ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -129,52 +131,119 @@ See #19226. -} +mayLookIdentical :: Type -> Type -> Bool +-- | Returns True if the /visible/ part of the types +-- might look equal, even if they are really unequal (in the invisible bits) +-- +-- This function is very similar to tc_eq_type but it is much more +-- heuristic. Notably, it is always safe to return True, even with types +-- that might (in truth) be unequal -- this affects error messages only +-- (Originally there were one function with an extra flag, but the result +-- was hard to understand.) +mayLookIdentical orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + go :: RnEnv2 -> Type -> Type -> Bool + -- See Note [Comparing nullary type synonyms] + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True + + go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + && go (rnBndr2 env tv1 tv2) ty1 ty2 + -- Visible stuff only: ignore kinds of binders + + -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond + -- with True. Reason: the type pretty-printer defaults RuntimeRep + -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make, + -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the + -- same as a very different type (#24553). By responding True, we + -- tell GHC (see calls of mayLookIdentical) to display without defaulting. + -- See Note [Showing invisible bits of types in error messages] + -- in GHC.Tc.Errors.Ppr + go _ (ForAllTy b _) _ | isDefaultableBndr b = True + go _ _ (ForAllTy b _) | isDefaultableBndr b = True + + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env arg1 arg2 && go env res1 res2 && go env w1 w2 + -- Visible stuff only: ignore agg kinds + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2 + + go _ _ _ = False + + gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool + gos _ _ [] [] = True + gos env bs (t1:ts1) (t2:ts2) + | (invisible, bs') <- case bs of + [] -> (False, []) + (b:bs) -> (isInvisibleTyConBinder b, bs) + = (invisible || go env t1 t2) && gos env bs' ts1 ts2 + + gos _ _ _ _ = False + + -- | Type equality comparing both visible and invisible arguments and expanding -- type synonyms. tcEqTypeNoSyns :: Type -> Type -> Bool -tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb - --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: Type -> Type -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 +tcEqTypeNoSyns ta tb = tc_eq_type False ta tb -- | Like 'pickyEqTypeVis', but returns a Bool for convenience pickyEqType :: Type -> Type -> Bool -- Check when two types _look_ the same, _including_ synonyms. -- So (pickyEqType String [Char]) returns False -- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 +pickyEqType ty1 ty2 = tc_eq_type True ty1 ty2 -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only -> Type -> Type -> Bool -- Flags False, False is the usual setting for tc_eq_type -- See Note [Computing equality on types] in Type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 +{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. +tc_eq_type keep_syns orig_ty1 orig_ty2 = go orig_env orig_ty1 orig_ty2 where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + go :: RnEnv2 -> Type -> Type -> Bool - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. - go _ (TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = True + -- See Note [Comparing nullary type synonyms] + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2 go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2' - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 - - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True go env (ForAllTy (Bndr tv1 vis1) ty1) (ForAllTy (Bndr tv2 vis2) ty2) = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] - && (vis_only || go env (varType tv1) (varType tv2)) + && go env (varType tv1) (varType tv2) && go (rnBndr2 env tv1 tv2) ty1 ty2 -- Make sure we handle all FunTy cases since falling through to the @@ -183,11 +252,9 @@ -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check -- kinds here go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) - = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 - where - kinds_eq | vis_only = True - | otherwise = go env (typeKind arg1) (typeKind arg2) && - go env (typeKind res1) (typeKind res2) + = go env (typeKind arg1) (typeKind arg2) && + go env (typeKind res1) (typeKind res2) && + go env arg1 arg2 && go env res1 res2 && go env w1 w2 -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2 @@ -198,32 +265,24 @@ = go env s1 s2 && go env t1 t2 go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True + = tc1 == tc2 && gos env ts1 ts2 go _ _ _ = False - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. - +isDefaultableBndr :: ForAllTyBinder -> Bool +-- This function should line up with the defaulting done +-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind +-- See Note [Showing invisible bits of types in error messages] +-- in GHC.Tc.Errors.Ppr +isDefaultableBndr (Bndr tv vis) + = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv) + where + is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function @@ -543,7 +602,7 @@ -- Returns both the resulting ordering relation between -- the two types and whether either contains a cast. go :: RnEnv2 -> Type -> Type -> TypeOrdering - -- See Note [Comparing nullary type synonyms]. + -- See Note [Comparing nullary type synonyms] go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = TEQ diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -14,7 +14,7 @@ pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, - pprDataCons, pprWithExplicitKindsWhen, + pprDataCons, pprWithInvisibleBitsWhen, pprWithTYPE, pprSourceTyCon, @@ -330,13 +330,14 @@ -- TODO: toIfaceTcArgs seems rather wasteful here ------------------ --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b +-- | Display all foralls, runtime-reps, and kind information +-- when provided 'Bool' argument is 'True'. See GHC.Tc.Errors.Ppr +-- Note [Showing invisible bits of types in error messages] +pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc +pprWithInvisibleBitsWhen b = updSDocContext $ \ctx -> - if b then ctx { sdocPrintExplicitKinds = True } + if b then ctx { sdocPrintExplicitKinds = True + , sdocPrintExplicitRuntimeReps = True } else ctx -- | This variant preserves any use of TYPE in a type, effectively diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -1190,6 +1190,24 @@ The Int in the AxiomInstCo constructor is the 0-indexed number of the chosen branch. +Note [Required foralls in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty). +It has type + forall a. e_ty +Note the Specified visibility of (forall a. e_ty); the Core type just isn't able +to express more than one visiblity, and we pick `Specified`. See `exprType` and +`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreLamForAllTyFlag`. + +So how can we ever get a term of type (forall a -> e_ty)? Answer: /only/ via a +cast built with ForAllCo. See `GHC.Tc.Types.Evidence.mkWpForAllCast`. This does +not seem very satisfying, but it does the job. + +An alternative would be to put a visibility flag into `Lam` (a huge change), +or into a `TyVar` (a more plausible change), but we leave that for the future. + +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + Note [ForAllCo] ~~~~~~~~~~~~~~~ See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. @@ -1246,10 +1264,7 @@ in the typing rule. See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. -(FC4) A lambda term (Lam a e) has type (forall a. ty), with visibility - flag `GHC.Type.Var.coreTyLamForAllTyFlag`, not (forall a -> ty). - See `GHC.Type.Var.coreTyLamForAllTyFlag` and `GHC.Core.Utils.mkLamType`. - The only way to get a term of type (forall a -> ty) is to cast a lambda. +(FC4) See Note [Required foralls in Core]. (FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy] diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -62,7 +62,7 @@ , mkCoercionType , coercionKind, coercionLKind, coVarKindsTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) -import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep 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 @@ -1954,6 +1954,8 @@ _ -> False -- | Is this a function? +-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function. +-- It would merely be a forall wrapping a function type. isFunTy :: Type -> Bool isFunTy ty | FunTy {} <- coreFullView ty = True 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 @@ -1066,7 +1066,7 @@ -- Respects newtypes, PredTypes -- See Note [Computing equality on types] in GHC.Core.Type unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. + -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare | tc1 == tc2 = return () 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 @@ -168,7 +168,7 @@ mkLamType v body_ty | isTyVar v = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty - -- coreTyLamForAllTyFlag: see (FC4) in Note [ForAllCo] + -- coreTyLamForAllTyFlag: see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep | isCoVar v diff --git a/compiler/GHC/Data/FlatBag.hs b/compiler/GHC/Data/FlatBag.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/FlatBag.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE UnboxedTuples #-} +module GHC.Data.FlatBag + ( FlatBag + , emptyFlatBag + , unitFlatBag + , sizeFlatBag + , elemsFlatBag + , mappendFlatBag + -- * Construction + , fromList + , fromSizedSeq + ) where + +import GHC.Prelude + +import GHC.Data.SizedSeq (SizedSeq, ssElts, sizeSS) + +import Control.DeepSeq + +import GHC.Data.SmallArray + +-- | Store elements in a flattened representation. +-- +-- A 'FlatBag' is a data structure that stores an ordered list of elements +-- in a flat structure, avoiding the overhead of a linked list. +-- Use this data structure, if the code requires the following properties: +-- +-- * Elements are stored in a long-lived object, and benefit from a flattened +-- representation. +-- * The 'FlatBag' will be traversed but not extended or filtered. +-- * The number of elements should be known. +-- * Sharing of the empty case improves memory behaviour. +-- +-- A 'FlagBag' aims to have as little overhead as possible to store its elements. +-- To achieve that, it distinguishes between the empty case, singleton, tuple +-- and general case. +-- Thus, we only pay for the additional three words of an 'Array' if we have at least +-- three elements. +data FlatBag a + = EmptyFlatBag + | UnitFlatBag !a + | TupleFlatBag !a !a + | FlatBag {-# UNPACK #-} !(SmallArray a) + +instance Functor FlatBag where + fmap _ EmptyFlatBag = EmptyFlatBag + fmap f (UnitFlatBag a) = UnitFlatBag $ f a + fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b) + fmap f (FlatBag e) = FlatBag $ mapSmallArray f e + +instance Foldable FlatBag where + foldMap _ EmptyFlatBag = mempty + foldMap f (UnitFlatBag a) = f a + foldMap f (TupleFlatBag a b) = f a `mappend` f b + foldMap f (FlatBag arr) = foldMapSmallArray f arr + + length = fromIntegral . sizeFlatBag + +instance Traversable FlatBag where + traverse _ EmptyFlatBag = pure EmptyFlatBag + traverse f (UnitFlatBag a) = UnitFlatBag <$> f a + traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b + traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl) + +instance NFData a => NFData (FlatBag a) where + rnf EmptyFlatBag = () + rnf (UnitFlatBag a) = rnf a + rnf (TupleFlatBag a b) = rnf a `seq` rnf b + rnf (FlatBag arr) = rnfSmallArray arr + +-- | Create an empty 'FlatBag'. +-- +-- The empty 'FlatBag' is shared over all instances. +emptyFlatBag :: FlatBag a +emptyFlatBag = EmptyFlatBag + +-- | Create a singleton 'FlatBag'. +unitFlatBag :: a -> FlatBag a +unitFlatBag = UnitFlatBag + +-- | Calculate the size of +sizeFlatBag :: FlatBag a -> Word +sizeFlatBag EmptyFlatBag = 0 +sizeFlatBag UnitFlatBag{} = 1 +sizeFlatBag TupleFlatBag{} = 2 +sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr + +-- | Get all elements that are stored in the 'FlatBag'. +elemsFlatBag :: FlatBag a -> [a] +elemsFlatBag EmptyFlatBag = [] +elemsFlatBag (UnitFlatBag a) = [a] +elemsFlatBag (TupleFlatBag a b) = [a, b] +elemsFlatBag (FlatBag arr) = + [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]] + +-- | Combine two 'FlatBag's. +-- +-- The new 'FlatBag' contains all elements from both 'FlatBag's. +-- +-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused. +mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a +mappendFlatBag EmptyFlatBag b = b +mappendFlatBag a EmptyFlatBag = a +mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b +mappendFlatBag a b = + fromList (sizeFlatBag a + sizeFlatBag b) + (elemsFlatBag a ++ elemsFlatBag b) + +-- | Store the list in a flattened memory representation, avoiding the memory overhead +-- of a linked list. +-- +-- The size 'n' needs to be smaller or equal to the length of the list. +-- If it is smaller than the length of the list, overflowing elements are +-- discarded. It is undefined behaviour to set 'n' to be bigger than the +-- length of the list. +fromList :: Word -> [a] -> FlatBag a +fromList n elts = + case elts of + [] -> EmptyFlatBag + [a] -> UnitFlatBag a + [a, b] -> TupleFlatBag a b + xs -> + FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs)) + +-- | Convert a 'SizedSeq' into its flattened representation. +-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification +-- is necessary. +fromSizedSeq :: SizedSeq a -> FlatBag a +fromSizedSeq s = fromList (sizeSS s) (ssElts s) diff --git a/compiler/GHC/Data/SmallArray.hs b/compiler/GHC/Data/SmallArray.hs --- a/compiler/GHC/Data/SmallArray.hs +++ b/compiler/GHC/Data/SmallArray.hs @@ -11,13 +11,18 @@ , freezeSmallArray , unsafeFreezeSmallArray , indexSmallArray + , sizeofSmallArray , listToArray + , mapSmallArray + , foldMapSmallArray + , rnfSmallArray ) where import GHC.Exts import GHC.Prelude import GHC.ST +import Control.DeepSeq data SmallArray a = SmallArray (SmallArray# a) @@ -64,6 +69,14 @@ case unsafeFreezeSmallArray# ma s of (# s', a #) -> (# s', SmallArray a #) +-- | Get the size of a 'SmallArray' +sizeofSmallArray + :: SmallArray a + -> Int +{-# INLINE sizeofSmallArray #-} +sizeofSmallArray (SmallArray sa#) = + case sizeofSmallArray# sa# of + s -> I# s -- | Index a small-array (no bounds checking!) indexSmallArray @@ -71,9 +84,51 @@ -> Int -- ^ index -> a {-# INLINE indexSmallArray #-} -indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of - (# v #) -> v +indexSmallArray (SmallArray sa#) (I# i) = + case indexSmallArray# sa# i of + (# v #) -> v +-- | Map a function over the elements of a 'SmallArray' +-- +mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b +{-# INLINE mapSmallArray #-} +mapSmallArray f sa = runST $ ST $ \s -> + let + n = sizeofSmallArray sa + go !i saMut# state# + | i < n = + let + a = indexSmallArray sa i + newState# = writeSmallArray saMut# i (f a) state# + in + go (i + 1) saMut# newState# + | otherwise = state# + in + case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of + (# s', mutArr #) -> + case go 0 mutArr s' of + s'' -> unsafeFreezeSmallArray mutArr s'' + +-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice +foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m +{-# INLINE foldMapSmallArray #-} +foldMapSmallArray f sa = go 0 + where + n = sizeofSmallArray sa + go i + | i < n = f (indexSmallArray sa i) `mappend` go (i + 1) + | otherwise = mempty + +-- | Force the elements of the given 'SmallArray' +-- +rnfSmallArray :: NFData a => SmallArray a -> () +{-# INLINE rnfSmallArray #-} +rnfSmallArray sa = go 0 + where + n = sizeofSmallArray sa + go !i + | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1) + | otherwise = () -- | Convert a list into an array. listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a diff --git a/compiler/GHC/Data/Word64Map/Strict.hs b/compiler/GHC/Data/Word64Map/Strict.hs --- a/compiler/GHC/Data/Word64Map/Strict.hs +++ b/compiler/GHC/Data/Word64Map/Strict.hs @@ -248,4 +248,3 @@ ) where import GHC.Data.Word64Map.Strict.Internal -import Prelude () diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -31,7 +31,7 @@ import GHC.Types.Error import GHC.Utils.Error import GHC.Driver.Errors.Types -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage import GHC.Utils.Outputable (text) import Data.Function diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs --- a/compiler/GHC/Driver/Config/Diagnostic.hs +++ b/compiler/GHC/Driver/Config/Diagnostic.hs @@ -19,7 +19,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- Diagnostic instances import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error diff --git a/compiler/GHC/Driver/DynFlags.hs b/compiler/GHC/Driver/DynFlags.hs --- a/compiler/GHC/Driver/DynFlags.hs +++ b/compiler/GHC/Driver/DynFlags.hs @@ -1300,6 +1300,8 @@ -- RegsGraph suffers performance regression. See #7679 -- , ([2], Opt_StaticArgumentTransformation) -- Static Argument Transformation needs investigation. See #9374 + , ([0,1,2], Opt_SpecEval) + , ([0,1,2], Opt_SpecEvalDictFun) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -14,8 +14,8 @@ import GHC.Driver.Errors.Types import GHC.Driver.Flags import GHC.Driver.DynFlags -import GHC.HsToCore.Errors.Ppr () -import GHC.Parser.Errors.Ppr () +import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage +import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage import GHC.Types.Error import GHC.Types.Error.Codes import GHC.Unit.Types @@ -30,8 +30,8 @@ import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) import GHC.Iface.Errors.Types -import GHC.Tc.Errors.Ppr () -import GHC.Iface.Errors.Ppr () +import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage +import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage -- -- Suggestions 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 @@ -316,7 +316,10 @@ | Opt_NumConstantFolding | Opt_CoreConstantFolding | Opt_FastPAPCalls -- #6084 + | Opt_SpecEval + | Opt_SpecEvalDictFun -- See Note [Controlling Speculative Evaluation] + -- Inference flags | Opt_DoTagInferenceChecks @@ -550,6 +553,8 @@ , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + , Opt_SpecEval + , Opt_SpecEvalDictFun ] -- | The set of flags which affect code generation and can change a program's diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -154,8 +154,6 @@ -> IO (Stream IO RawCmmGroup a))) } -{-# DEPRECATED cmmToRawCmmHook "cmmToRawCmmHook is being deprecated. If you do use it in your project, please raise a GHC issue!" #-} - class HasHooks m where getHooks :: m Hooks 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 @@ -420,12 +420,12 @@ loadExternalPluginLib path = do -- load library loadDLL path >>= \case - Just errmsg -> pprPanic "loadExternalPluginLib" - (vcat [ text "Can't load plugin library" - , text " Library path: " <> text path - , text " Error : " <> text errmsg - ]) - Nothing -> do + Left errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Right _ -> do -- resolve objects resolveObjs >>= \case True -> return () 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 @@ -113,6 +113,10 @@ sOpt_L, sOpt_P, sOpt_P_fingerprint, + sOpt_JSP, + sOpt_JSP_fingerprint, + sOpt_CmmP, + sOpt_CmmP_fingerprint, sOpt_F, sOpt_c, sOpt_cxx, @@ -135,11 +139,11 @@ ghcUsagePath, ghciUsagePath, topDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, - pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, pgm_lm, - pgm_windres, pgm_ar, + pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, + pgm_lm, pgm_windres, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i, - opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, - opt_P_signature, + opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, + opt_P_signature, opt_JSP_signature, opt_CmmP_signature, opt_windres, opt_lo, opt_lc, opt_las, updatePlatformConstants, @@ -391,6 +395,10 @@ pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags pgm_P :: DynFlags -> (String,[Option]) pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_JSP :: DynFlags -> (String,[Option]) +pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags +pgm_CmmP :: DynFlags -> (String,[Option]) +pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags pgm_F :: DynFlags -> String pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags pgm_c :: DynFlags -> String @@ -424,6 +432,11 @@ opt_P :: DynFlags -> [String] opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_P (toolSettings dflags) +opt_JSP :: DynFlags -> [String] +opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_JSP (toolSettings dflags) +opt_CmmP :: DynFlags -> [String] +opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags -- This function packages everything that's needed to fingerprint opt_P -- flags. See Note [Repeated -optP hashing]. @@ -432,6 +445,17 @@ ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) , toolSettings_opt_P_fingerprint $ toolSettings dflags ) +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_JSP_signature :: DynFlags -> ([String], Fingerprint) +opt_JSP_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_JSP_fingerprint $ toolSettings dflags + ) +-- This function packages everything that's needed to fingerprint opt_CmmP +-- flags. See Note [Repeated -optP hashing]. +opt_CmmP_signature :: DynFlags -> Fingerprint +opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings opt_F :: DynFlags -> [String] opt_F dflags= toolSettings_opt_F $ toolSettings dflags @@ -580,7 +604,8 @@ setDynObjectSuf, setDynHiSuf, setDylibInstallName, setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptc, addOptcxx, addOptP, + setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP, + addOptJSP, addOptCmmP, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags @@ -670,6 +695,14 @@ -- Config.hs should really use Option. setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) where (pgm:args) = words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmJSP f = alterToolSettings (\s -> s { toolSettings_pgm_JSP = (pgm, map Option args)}) + where (pgm:args) = words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)}) + where (pgm:args) = words f addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) @@ -678,9 +711,15 @@ , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) } -- See Note [Repeated -optP hashing] - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - +addOptJSP f = alterToolSettings $ \s -> s + { toolSettings_opt_JSP = f : toolSettings_opt_JSP s + , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s) + } + -- See Note [Repeated -optP hashing] +addOptCmmP f = alterToolSettings $ \s -> s + { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s + , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s) + } setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } @@ -1071,6 +1110,10 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } , make_ord_flag defFlag "pgmP" (hasArg setPgmP) + , make_ord_flag defFlag "pgmJSP" + (hasArg setPgmJSP) + , make_ord_flag defFlag "pgmCmmP" + (hasArg setPgmCmmP) , make_ord_flag defFlag "pgmF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } , make_ord_flag defFlag "pgmc" @@ -1125,6 +1168,10 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } , make_ord_flag defFlag "optP" (hasArg addOptP) + , make_ord_flag defFlag "optJSP" + (hasArg addOptJSP) + , make_ord_flag defFlag "optCmmP" + (hasArg addOptCmmP) , make_ord_flag defFlag "optF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } , make_ord_flag defFlag "optc" @@ -2486,6 +2533,8 @@ flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "core-constant-folding" Opt_CoreConstantFolding, flagSpec "fast-pap-calls" Opt_FastPAPCalls, + flagSpec "spec-eval" Opt_SpecEval, + flagSpec "spec-eval-dictfun" Opt_SpecEvalDictFun, flagSpec "cmm-control-flow" Opt_CmmControlFlow, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -38,6 +38,7 @@ HsWildCardBndrs(..), HsPatSigType(..), HsPSRn(..), HsTyPat(..), HsTyPatRn(..), + HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn, HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, fromMaybeContext, @@ -128,6 +129,7 @@ import Data.Data (Data) import qualified Data.Semigroup as S +import GHC.Data.Bag {- ************************************************************************ @@ -244,6 +246,51 @@ , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names } deriving Data + +-- | A variant of HsTyPatRn that uses Bags for efficient concatenation. +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRnBuilder = + HsTPRnB { + hstpb_nwcs :: Bag Name, + hstpb_imp_tvs :: Bag Name, + hstpb_exp_tvs :: Bag Name + } + +tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder +tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name} + +tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder +tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} = + mempty { + hstpb_nwcs = listToBag hsps_nwcs, + hstpb_imp_tvs = listToBag hsps_imp_tvs + } + +instance Semigroup HsTyPatRnBuilder where + HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 = + HsTPRnB + (nwcs1 `unionBags` nwcs2) + (imp_tvs1 `unionBags` imp_tvs2) + (exptvs1 `unionBags` exptvs2) + +instance Monoid HsTyPatRnBuilder where + mempty = HsTPRnB emptyBag emptyBag emptyBag + +buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn +buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} = + HsTPRn { + hstp_nwcs = bagToList hstpb_nwcs, + hstp_imp_tvs = bagToList hstpb_imp_tvs, + hstp_exp_tvs = bagToList hstpb_exp_tvs + } + +builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder +builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} = + HsTPRnB { + hstpb_nwcs = listToBag hstp_nwcs, + hstpb_imp_tvs = listToBag hstp_imp_tvs, + hstpb_exp_tvs = listToBag hstp_exp_tvs + } type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XXHsTyPat (GhcPass _) = DataConCantHappen diff --git a/compiler/GHC/Iface/Errors/Ppr.hs b/compiler/GHC/Iface/Errors/Ppr.hs --- a/compiler/GHC/Iface/Errors/Ppr.hs +++ b/compiler/GHC/Iface/Errors/Ppr.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage {-# LANGUAGE InstanceSigs #-} module GHC.Iface.Errors.Ppr 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 @@ -85,7 +85,7 @@ import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary -import GHC.Utils.Binary.Typeable () +import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, 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 @@ -1132,7 +1132,7 @@ -> IfaceType go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification - -- or we get the mess in #13963 + -- 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/Lifted/Many, diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -6,7 +6,7 @@ where -- Empty import to influence the compilation ordering. --- See Note [Depend on GHC.Num.Integer] in GHC.Base +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base import GHC.Base () data IfaceAppArgs 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 @@ -40,7 +40,8 @@ import GHC.Unit ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) -import GHCi.RemoteTypes ( ForeignHValue ) +import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) +import GHCi.Message ( LoadedDLL ) import GHC.Types.Var ( Id ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) @@ -75,6 +76,53 @@ The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. + +Note [Looking up symbols in the relevant objects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #23415, we determined that a lot of time (>10s, or even up to >35s!) was +being spent on dynamically loading symbols before actually interpreting code +when `:main` was run in GHCi. The root cause was that for each symbol we wanted +to lookup, we would traverse the list of loaded objects and try find the symbol +in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in +the amount of loaded objects). + +To drastically improve load time (from +-38 seconds down to +-2s), we now: + +1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. + - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to + `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. + +2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in + the `pkgs_loaded` mapping, + +3. And only look for the symbol (with `dlsym`) on the /handles relevant to that + unit/, rather than in every loaded object. + +Note [Symbols may not be found in pkgs_loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently the `pkgs_loaded` mapping only contains the dynamic objects +associated with loaded units. Symbols defined in a static object (e.g. from a +statically-linked Haskell library) are found via the generic `lookupSymbol` +function call by `lookupHsSymbol` when the symbol is not found in any of the +dynamic objects of `pkgs_loaded`. + +The rationale here is two-fold: + + * we have only observed major link-time issues in dynamic linking; lookups in + the RTS linker's static symbol table seem to be fast enough + + * allowing symbol lookups restricted to a single ObjectCode would require the + maintenance of a symbol table per `ObjectCode`, which would introduce time and + space overhead + +This fallback is further needed because we don't look in the haskell objects +loaded for the home units (see the call to `loadModuleLinkables` in +`loadDependencies`, as opposed to the call to `loadPackages'` in the same +function which updates `pkgs_loaded`). We should ultimately keep track of the +objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit +unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) +and be able to lookup symbols specifically in them too (similarly to +`lookupSymbolInDLL`). -} newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } @@ -146,11 +194,13 @@ { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] + , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] + -- ^ See Note [Looking up symbols in the relevant objects] , loaded_pkg_trans_deps :: UniqDSet UnitId } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) = + ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = vcat [ppr uid , ppr hs_objs , ppr non_hs_objs @@ -159,10 +209,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/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -139,7 +139,6 @@ import GHC.Parser.Types import GHC.Parser.Lexer import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing import GHC.Core.Type ( Specificity(..) ) diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -79,7 +79,7 @@ , platformTablesNextToCode :: !Bool -- ^ Determines whether we will be compiling info tables that reside just -- before the entry code, or with an indirection to the entry code. See - -- TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h. + -- TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@. , platformHasLibm :: !Bool -- ^ Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See 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 @@ -19,7 +19,7 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing -import GHC.Types.BreakInfo +import GHC.Types.Breakpoint import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception @@ -50,8 +50,8 @@ , execAllocation :: Word64 } | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo + { breakNames :: [Name] + , breakPointId :: Maybe InternalBreakpointId } -- | Essentially a GlobalRdrEnv, but with additional cached values to allow @@ -73,11 +73,10 @@ , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) + , resumeBreakpointId :: Maybe InternalBreakpointId + -- ^ the breakpoint we stopped at -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, -- otherwise it's a pain to -- fetch the ModDetails & @@ -90,9 +89,8 @@ type ResumeBindings = ([TyThing], IcGlobalRdrEnv) -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } +data History = History + { historyApStack :: ForeignHValue + , historyBreakpointId :: InternalBreakpointId -- ^ breakpoint identifier + , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint + } diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs --- a/compiler/GHC/Runtime/Interpreter/Types.hs +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -51,6 +51,9 @@ , interpLoader :: !Loader -- ^ Interpreter loader + + , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) + -- ^ LookupSymbol cache } data InterpInstance @@ -107,9 +110,6 @@ -- ^ Values that need to be freed before the next command is sent. -- Finalizers for ForeignRefs can append values to this list -- asynchronously. - - , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) - -- ^ LookupSymbol cache , instExtra :: !c -- ^ Instance specific extra fields diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -26,6 +26,8 @@ , sArSupportsDashL , sPgm_L , sPgm_P + , sPgm_JSP + , sPgm_CmmP , sPgm_F , sPgm_c , sPgm_cxx @@ -45,6 +47,10 @@ , sOpt_L , sOpt_P , sOpt_P_fingerprint + , sOpt_JSP + , sOpt_JSP_fingerprint + , sOpt_CmmP + , sOpt_CmmP_fingerprint , sOpt_F , sOpt_c , sOpt_cxx @@ -92,11 +98,16 @@ , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool , toolSettings_arSupportsDashL :: Bool + , toolSettings_cmmCppSupportsG0 :: Bool -- commands for particular phases , toolSettings_pgm_L :: String , -- | The Haskell C preprocessor and default options (not added by -optP) toolSettings_pgm_P :: (String, [Option]) + , -- | The JavaScript C preprocessor and default options (not added by -optP) + toolSettings_pgm_JSP :: (String, [Option]) + , -- | The C-- C Preprocessor and default options (not added by -optP) + toolSettings_pgm_CmmP :: (String, [Option]) , toolSettings_pgm_F :: String , toolSettings_pgm_c :: String , toolSettings_pgm_cxx :: String @@ -124,9 +135,17 @@ -- options for particular phases , toolSettings_opt_L :: [String] , toolSettings_opt_P :: [String] + , toolSettings_opt_JSP :: [String] + , toolSettings_opt_CmmP :: [String] , -- | cached Fingerprint of sOpt_P -- See Note [Repeated -optP hashing] - toolSettings_opt_P_fingerprint :: Fingerprint + toolSettings_opt_P_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_JSP + -- See Note [Repeated -optP hashing] + toolSettings_opt_JSP_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_CmmP + -- See Note [Repeated -optP hashing] + toolSettings_opt_CmmP_fingerprint :: Fingerprint , toolSettings_opt_F :: [String] , toolSettings_opt_c :: [String] , toolSettings_opt_cxx :: [String] @@ -205,6 +224,10 @@ sPgm_L = toolSettings_pgm_L . sToolSettings sPgm_P :: Settings -> (String, [Option]) sPgm_P = toolSettings_pgm_P . sToolSettings +sPgm_JSP :: Settings -> (String, [Option]) +sPgm_JSP = toolSettings_pgm_JSP . sToolSettings +sPgm_CmmP :: Settings -> (String, [Option]) +sPgm_CmmP = toolSettings_pgm_CmmP . sToolSettings sPgm_F :: Settings -> String sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String @@ -243,6 +266,14 @@ sOpt_P = toolSettings_opt_P . sToolSettings sOpt_P_fingerprint :: Settings -> Fingerprint sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings +sOpt_JSP :: Settings -> [String] +sOpt_JSP = toolSettings_opt_JSP . sToolSettings +sOpt_JSP_fingerprint :: Settings -> Fingerprint +sOpt_JSP_fingerprint = toolSettings_opt_JSP_fingerprint . sToolSettings +sOpt_CmmP :: Settings -> [String] +sOpt_CmmP = toolSettings_opt_CmmP . sToolSettings +sOpt_CmmP_fingerprint :: Settings -> Fingerprint +sOpt_CmmP_fingerprint = toolSettings_opt_CmmP_fingerprint . sToolSettings sOpt_F :: Settings -> [String] sOpt_F = toolSettings_opt_F . sToolSettings sOpt_c :: Settings -> [String] diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs --- a/compiler/GHC/StgToCmm/Config.hs +++ b/compiler/GHC/StgToCmm/Config.hs @@ -70,8 +70,11 @@ , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction + , stgToCmmAllowWordMul2Instr :: !Bool -- ^ Allowed to generate WordMul2 instruction , stgToCmmAllowFMAInstr :: FMASign -> Bool -- ^ Allowed to generate FMA instruction , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. + , stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see + -- Note [Saving foreign call target to local] for details ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested -- during compilation. In essence, this means checking for @-fllvm@ which is diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs --- a/compiler/GHC/StgToJS/Types.hs +++ b/compiler/GHC/StgToJS/Types.hs @@ -26,7 +26,7 @@ import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.JS.Make -import GHC.JS.Ppr () +import GHC.JS.Ppr () -- expose Outputable instances to downstream modules import GHC.Stg.Syntax import GHC.Core.TyCon diff --git a/compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot b/compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot --- a/compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Errors.Hole.Plugin where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data HoleFitPlugin 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 @@ -54,8 +54,8 @@ import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) -import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) +import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon, + pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type @@ -536,7 +536,7 @@ , text "cannot be inferred from the right-hand side." ] in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) - in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $ + in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $ hang herald 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) TcRnBangOnUnliftedType ty @@ -1182,7 +1182,7 @@ ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) IsGADT -> (text "A newtype must not be a GADT", - ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec + ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec (ppr $ dataConDisplayType show_linear_types con)) HasConstructorContext -> (text "A newtype constructor must not have a context in its type", @@ -1432,7 +1432,7 @@ , text "Perhaps enable PolyKinds or add a kind signature" ]) TcRnUninferrableTyVar tidied_tvs context -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ text "Uninferrable type variable" <> plural tidied_tvs <+> pprWithCommas pprTyVar tidied_tvs @@ -1440,7 +1440,7 @@ , pprUninferrableTyVarCtx context ] TcRnSkolemEscape escapees tv orig_ty -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees , quotes $ pprTyVars escapees , text "would escape" <+> itsOrTheir escapees <+> text "scope" @@ -1884,7 +1884,7 @@ TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ text "Invalid defaulting proposal." , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon) 2 (pprQuotedList (NE.toList bad_tvs)) @@ -4153,17 +4153,18 @@ | otherwise = text "kind" <+> quotes (ppr exp) pprMismatchMsg ctxt - (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item + (TypeEqMismatch { teq_mismatch_item = item , teq_mismatch_ty1 = ty1 -- These types are the actual types , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped , teq_mismatch_expected = exp -- These are the context of , teq_mismatch_actual = act -- the mis-match , teq_mismatch_what = mb_thing , teq_mb_same_occ = mb_same_occ }) - = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - $$ maybe empty pprSameOccInfo mb_same_occ + = addArising ct_loc $ + pprWithInvisibleBitsWhen ppr_invis_bits msg + $$ maybe empty pprSameOccInfo mb_same_occ where + msg | Just (torc, rep) <- sORTKind_maybe exp = msg_for_exp_sort torc rep @@ -4226,6 +4227,7 @@ ct_loc = errorItemCtLoc item orig = errorItemOrigin item level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig num_args_msg = case level of KindLevel @@ -4317,7 +4319,61 @@ _ -> pprTheta wanteds +-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. +-- See Note [Showing invisible bits of types in error messages] +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible +-- equality; if it's not, definitely print the kinds. Even if the equality is +-- a visible equality, check the expected/actual types to see if the types +-- have equal visible components. If the 'CtOrigin' is +-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. +shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool +shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_visible = vis }) + | not vis = True -- See tests T15870, T16204c + | otherwise = mayLookIdentical act exp -- See tests T9171, T9144. +shouldPprWithInvisibleBits ty1 ty2 _ct + = mayLookIdentical ty1 ty2 +{- Note [Showing invisible bits of types in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, when we find a type or kind mis-match: + +* See if normally-visible parts of the type would make the two types + look different. This check is made by + `GHC.Core.TyCo.Compare.mayLookIdentical` + +* If not, display the types with their normally-visible parts made visible, + by setting flags in the `SDocContext": + Specifically: + - Display kind arguments: sdocPrintExplicitKinds + - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps, + which controls `GHC.Iface.Type.hideNonStandardTypes` + (NB: foralls are always printed by pprType, it turns out.) + +As a result the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. + +Another example of what goes wrong without this: #24553. +-} + {- ********************************************************************* * * Displaying potential instances @@ -6040,7 +6096,7 @@ IllegalFamilyInstance reason -> pprIllegalFamilyInstance reason IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args -> - pprWithExplicitKindsWhen invis_arg $ + pprWithInvisibleBitsWhen invis_arg $ hang (text "Illegal type synonym family application" <+> quotes (ppr tf_ty) <+> text "in instance" <> colon) 2 (ppr inst_ty) @@ -6123,7 +6179,7 @@ , not_covered_invis_vis_tvs = undetermined_tvs , not_covered_liberal = which_cc_failed } = - pprWithExplicitKindsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ + pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ vcat [ sep [ text "The" <+> ppWhen liberal (text "liberal") <+> text "coverage condition fails in class" @@ -6385,7 +6441,7 @@ , text "mentions none of the type or kind variables of the class" <+> quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))] AssocTyVarsDontMatch vis fam_tc exp_tys act_tys -> - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ + pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $ vcat [ text "Type indexes must match class instance head" , text "Expected:" <+> pp exp_tys , text " Actual:" <+> pp act_tys ] @@ -6409,7 +6465,7 @@ let (pat_tv, pat_vis) = NE.head dups in (pat_vis, text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") - in pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ + in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $ hang main_msg 2 (vcat [ppr_eqn, suggestion]) where 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 @@ -5525,8 +5525,7 @@ -- -- Test cases: T1470, tcfail212. | TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_item :: ErrorItem + { teq_mismatch_item :: ErrorItem , teq_mismatch_ty1 :: Type , teq_mismatch_ty2 :: Type , teq_mismatch_expected :: Type -- ^ The overall expected type 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 @@ -534,6 +534,10 @@ tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. + tcg_zany_n :: TcRef Integer, + -- ^ A source of unique identities for ZonkAny instances + -- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) + tcg_merged :: [(Module, Fingerprint)], -- ^ The requirements we merged with; we always have to recompile -- if any of these changed. 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 @@ -83,7 +83,7 @@ ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, ctEvRewriters, ctEvUnique, tcEvDestUnique, mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc, - ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens, + ctEvRole, setCtEvPredType, setCtEvLoc, tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, -- RewriterSet @@ -1312,25 +1312,51 @@ insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) = anyBag insolubleWantedCt simples + -- insolubleWantedCt: wanteds only: see Note [Given insolubles] || anyBag insolubleImplic implics || anyBag is_insoluble errors - - where + where is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] is_insoluble (DE_NotConcrete {}) = True insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely: --- a) an insoluble constraint as per 'insolubleCt', i.e. either +-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either -- - an insoluble equality constraint (e.g. Int ~ Bool), or -- - a custom type error constraint, TypeError msg :: Constraint -- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- See Note [Insoluble Wanteds] +insolubleWantedCt ct + | CIrredCan ir_ct <- ct + -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] + , IrredCt { ir_ev = ev } <- ir_ct + , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev + -- It's a Wanted + , insolubleIrredCt ir_ct + -- It's insoluble + , isEmptyRewriterSet rewriters + -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + , not (isGivenLoc loc) + -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) + -- origin check: see (IW4) in Note [Insoluble Wanteds] + = True + + | otherwise + = False + +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. -- --- See Note [Given insolubles]. -insolubleWantedCt ct = insolubleCt ct && - not (arisesFromGivens ct) && - not (isWantedWantedFunDepOrigin (ctOrigin ct)) +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble @@ -1360,18 +1386,6 @@ -- > Assert 'True _errMsg = () -- > Assert _check errMsg = errMsg --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan -insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool @@ -1415,6 +1429,31 @@ Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) should ignore givens even if they are insoluble. +Note [Insoluble Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~ +insolubleWantedCt returns True of a Wanted constraint that definitely +can't be solved. But not quite all such constraints; see wrinkles. + +(IW1) insolubleWantedCt is tuned for application /after/ constraint + solving i.e. assuming canonicalisation has been done. That's why + it looks only for IrredCt; all insoluble constraints are put into + CIrredCan + +(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note + [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A + that is /not/ insoluble rewrites some other Wanted constraint B, so B has A + in its rewriter set. Now B looks insoluble. The danger is that we'll + suppress reporting B because of its empty rewriter set; and suppress + reporting A because there is an insoluble B lying around. (This suppression + happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. + +(IW3) If the Wanted arises from a Given (how can that happen?), don't + treat it as a Wanted insoluble (obviously). + +(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't + treat the constraint as insoluble. See Note [Suppressing confusing errors] + in GHC.Tc.Errors + Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble: @@ -2055,9 +2094,6 @@ setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc } - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- | Set the type of CtEvidence. -- 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 @@ -7,7 +7,7 @@ -- * HsWrapper HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpVisTyLam, + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast, mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, @@ -258,20 +258,20 @@ mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids --- Construct a type lambda and cast its type --- from `forall tv. res` to `forall tv -> res`. --- --- (\ @tv -> e ) --- `cast` (forall (tv[spec]~[req] :: <*>_N). _R -- ForAllCo is the evidence that... --- :: (forall tv. res) ~R# (forall tv -> res)) -- invisible and visible foralls are representationally equal +-- mkWpForAllCast [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep -- -mkWpVisTyLam :: TyVar -> Type -> HsWrapper -mkWpVisTyLam tv res = - WpCast (mkForAllCo tv coreTyLamForAllTyFlag Required kind_co body_co) - <.> WpTyLam tv +-- It's a no-op if all binders are invisible; +-- but in that case we refrain from calling it. +mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper +mkWpForAllCast bndrs res_ty + = mkWpCastR (go bndrs) where - kind_co = mkNomReflCo (varType tv) - body_co = mkRepReflCo res + go [] = mkRepReflCo res_ty + go (Bndr tv vis : bs) = mkForAllCo tv coreTyLamForAllTyFlag vis kind_co (go bs) + where + kind_co = mkNomReflCo (varType tv) mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids diff --git a/compiler/GHC/Tc/Types/LclEnv.hs-boot b/compiler/GHC/Tc/Types/LclEnv.hs-boot --- a/compiler/GHC/Tc/Types/LclEnv.hs-boot +++ b/compiler/GHC/Tc/Types/LclEnv.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Types.LclEnv where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data TcLclEnv 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 @@ -67,7 +67,7 @@ -------------------------------- -- Splitters getTyVar, getTyVar_maybe, getCastedTyVar_maybe, - tcSplitForAllTyVarBinder_maybe, + tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders, @@ -95,7 +95,7 @@ -- Re-exported from GHC.Core.TyCo.Compare -- mainly just for back-compat reasons eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical, tcEqTyConApps, eqForAllVis, eqVarBndrs, --------------------------------- @@ -888,7 +888,8 @@ -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a -- /visible/ argument to @C@. -- --- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". +-- See also Note [Showing invisible bits of types in error messages] +-- in "GHC.Tc.Errors.Ppr". tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVis = tcTyFamInstsAndVisX False @@ -1405,6 +1406,18 @@ | argf_pred argf = split ty ty (tv:tvs) split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) + +tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type) +-- Split off at most N /required/ (aka visible) binders, plus any invisible ones +-- in the way, /and/ any trailing invisible ones +tcSplitForAllTyVarsReqTVBindersN n_req ty + = split n_req ty ty [] + where + split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs + | isVisibleForAllTyFlag argf, n_req > 0 = split (n_req - 1) ty ty (b:bs) + | otherwise = split n_req ty ty (b:bs) + split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs + split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty) -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. diff --git a/compiler/GHC/Types/BreakInfo.hs b/compiler/GHC/Types/BreakInfo.hs deleted file mode 100644 --- a/compiler/GHC/Types/BreakInfo.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | 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/Breakpoint.hs b/compiler/GHC/Types/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Types/Breakpoint.hs @@ -0,0 +1,53 @@ +-- | Breakpoint related types +module GHC.Types.Breakpoint + ( BreakpointId (..) + , InternalBreakpointId (..) + , toBreakpointId + ) +where + +import GHC.Prelude +import GHC.Unit.Module + +-- | Breakpoint identifier. +-- +-- See Note [Breakpoint identifiers] +data BreakpointId = BreakpointId + { bi_tick_mod :: !Module -- ^ Breakpoint tick module + , bi_tick_index :: !Int -- ^ Breakpoint tick index + } + +-- | Internal breakpoint identifier +-- +-- See Note [Breakpoint identifiers] +data InternalBreakpointId = InternalBreakpointId + { ibi_tick_mod :: !Module -- ^ Breakpoint tick module + , ibi_tick_index :: !Int -- ^ Breakpoint tick index + , ibi_info_mod :: !Module -- ^ Breakpoint info module + , ibi_info_index :: !Int -- ^ Breakpoint info index + } + +toBreakpointId :: InternalBreakpointId -> BreakpointId +toBreakpointId ibi = BreakpointId + { bi_tick_mod = ibi_tick_mod ibi + , bi_tick_index = ibi_tick_index ibi + } + + +-- Note [Breakpoint identifiers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Before optimization a breakpoint is identified uniquely with a tick module +-- and a tick index. See BreakpointId. A tick module contains an array, indexed +-- with the tick indexes, which indicates breakpoint status. +-- +-- When we generate ByteCode, we collect information for every breakpoint at +-- their *occurrence sites* (see CgBreakInfo in GHC.ByteCode.Types) and these info +-- are stored in the ModIface of the occurrence module. Because of inlining, we +-- can't reuse the tick index to uniquely identify an occurrence; because of +-- cross-module inlining, we can't assume that the occurrence module is the same +-- as the tick module (#24712). +-- +-- So every breakpoint occurrence gets assigned a module-unique *info index* and +-- we store it alongside the occurrence module (*info module*) in the +-- InternalBreakpointId datatype. 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 @@ -37,7 +37,7 @@ -- *** Demands used in PrimOp signatures lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd, -- ** Other @Demand@ operations - oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, + oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information @@ -607,22 +607,22 @@ -- -- Examples (using Note [Demand notation]): -- --- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument --- strictly (@1@), but not any deeper (@A@). --- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument +-- * 'seq' puts demand `1A` on its first argument: It evaluates the argument +-- strictly (`1`), but not any deeper (`A`). +-- * 'fst' puts demand `1P(1L,A)` on its argument: It evaluates the argument -- pair strictly and the first component strictly, but no nested info --- beyond that (@L@). Its second argument is not used at all. --- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the --- argument function with one argument, exactly once (@1@). No info --- on how the result of that call is evaluated (@L@). --- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates +-- beyond that (`L`). Its second argument is not used at all. +-- * '$' puts demand `1C(1,L)` on its first argument: It calls (`C`) the +-- argument function with one argument, exactly once (`1`). No info +-- on how the result of that call is evaluated (`L`). +-- * 'maybe' puts demand `MC(M,L)` on its second argument: It evaluates -- the argument function at most once ((M)aybe) and calls it once when -- it is evaluated. --- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@ --- multiplied by two, so we get @S@ (used at least once, possibly multiple +-- * `fst p + fst p` puts demand `SP(SL,A)` on `p`: It's `1P(1L,A)` +-- multiplied by two, so we get `S` (used at least once, possibly multiple -- times). -- --- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled +-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there @@ -1012,6 +1012,11 @@ lazifyDmd :: Demand -> Demand lazifyDmd = multDmd C_01 +-- | Adjust the demand on a binding that may float outwards +-- See Note [Floatifying demand info when floating] +floatifyDmd :: Demand -> Demand +floatifyDmd = multDmd C_0N + -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd @@ -2634,7 +2639,12 @@ but it's always clear from context which "overload" is meant. It's like return-type inference of e.g. 'read'. -Examples are in the haddock for 'Demand'. +Examples are in the haddock for 'Demand'. Here are some more: + SA Strict, but does not look at subcomponents (`seq`) + SP(L,L) Strict boxed pair, components lazy + S!P(L,L) Strict unboxed pair, components lazy + LP(SA,SA) Lazy pair, but if it is evaluated will evaluated its components + LC(1C(L)) Lazy, but if called will apply the result exactly once This is the syntax for demand signatures: 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 @@ -54,7 +54,7 @@ setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, @@ -296,26 +296,28 @@ mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - +mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo nm = + assertPpr (not $ isFieldNameSpace $ nameNameSpace nm) + (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $ + mkGlobalId VanillaId nm -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold. @@ -339,7 +341,10 @@ -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo +mkExportedVanillaId name ty = + assertPpr (not $ isFieldNameSpace $ nameNameSpace name) + (text "mkExportedVanillaId called on record field:" <+> ppr name) $ + Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] @@ -958,12 +963,11 @@ updOneShotInfo :: Id -> OneShotInfo -> Id -- Combine the info in the Id with new info updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False + | OneShotLam <- one_shot + , NoOneShotInfo <- idOneShotInfo id + = setIdOneShotInfo id OneShotLam + | otherwise + = id -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else @@ -980,8 +984,9 @@ zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo +floatifyIdDemandInfo :: Id -> Id +-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels +floatifyIdDemandInfo = zapInfo floatifyDemandInfo zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo diff --git a/compiler/GHC/Types/Id.hs-boot b/compiler/GHC/Types/Id.hs-boot --- a/compiler/GHC/Types/Id.hs-boot +++ b/compiler/GHC/Types/Id.hs-boot @@ -1,6 +1,5 @@ module GHC.Types.Id where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name import {-# SOURCE #-} GHC.Types.Var 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 @@ -35,7 +35,8 @@ -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + lazifyDemandInfo, floatifyDemandInfo, + zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, zapTailCallInfo, zapCallArityInfo, trimUnfolding, -- ** The ArityInfo type @@ -855,11 +856,21 @@ is_safe_dmd dmd = not (isStrUsedDmd dmd) --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) +-- | Lazify (remove the top-level demand, only) the demand in `IdInfo` +-- Keep nested demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +lazifyDemandInfo :: IdInfo -> Maybe IdInfo +lazifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = lazifyDmd dmd }) --- | Remove usage (but not strictness) info on the 'IdInfo' +-- | Floatify the demand in `IdInfo` +-- But keep /nested/ demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +floatifyDemandInfo :: IdInfo -> Maybe IdInfo +floatifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = floatifyDmd dmd }) + +-- | Remove usage (but not strictness) info on the `IdInfo` zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) 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 @@ -902,15 +902,25 @@ -- needs a wrapper. This wrapper is injected into the program later in the -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, -- along with the accompanying implementation in getTyConImplicitBinds. - wrapper_reqd = - (not new_tycon + wrapper_reqd + | isTypeDataTyCon tycon + -- `type data` declarations never have data-constructor wrappers + -- Their data constructors only live at the type level, in the + -- form of PromotedDataCon, and therefore do not need wrappers. + -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module. + = False + + | otherwise + = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec) + || isFamInstTyCon tycon -- Cast result - || (dataConUserTyVarsNeedWrapper data_con + + || dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder @@ -919,19 +929,7 @@ -- -- NB: All GADTs return true from this function, but there -- is one exception that we must check below. - && not (isTypeDataTyCon tycon)) - -- An exception to this rule is `type data` declarations. - -- Their data constructors only live at the type level and - -- therefore do not need wrappers. - -- See Note [Type data declarations] in GHC.Rename.Module. - -- - -- Note that the other checks in this definition will - -- return False for `type data` declarations, as: - -- - -- - They cannot be newtypes - -- - They cannot have strict fields - -- - They cannot be data family instances - -- - They cannot have datatype contexts + || not (null stupid_theta) -- If the data constructor has a datatype context, -- we need a wrapper in order to drop the stupid arguments. diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -123,7 +123,8 @@ , fUNTyConName, unrestrictedFunTyConName , oneDataConName , listTyConName - , manyDataConName ] + , manyDataConName + , soloDataConName ] || isJust (isTupleTyOcc_maybe mod occ) || isJust (isSumTyOcc_maybe mod occ) diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -693,6 +693,9 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty + -- Currently ghc has no unlifted functions. + | definitelyUnliftedType ty + = False | [BoxedRep _] <- typePrimRep ty , Just tc <- tyConAppTyCon_maybe (unwrapType ty) , isDataTyCon tc diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -503,7 +503,7 @@ coreTyLamForAllTyFlag :: ForAllTyFlag -- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable. -- If you want other ForAllTyFlag, use a cast. --- See Note [ForAllCo] in GHC.Core.TyCo.Rep +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep coreTyLamForAllTyFlag = Specified instance Outputable ForAllTyFlag where diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot --- a/compiler/GHC/Types/Var.hs-boot +++ b/compiler/GHC/Types/Var.hs-boot @@ -1,13 +1,7 @@ {-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name - -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports - -- it does not seem to depend on anything. But it does! We must, for - -- example, compile GHC.Types in the ghc-prim library first. So this - -- otherwise-unnecessary import tells the build system that this module - -- depends on GhcPrelude, which ensures that GHC.Type is built first. data ForAllTyFlag data FunTyFlag 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 @@ -106,7 +106,7 @@ import Control.DeepSeq (NFData(..)) import Data.Data -import Data.List (sortBy ) +import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS diff --git a/compiler/GHC/Utils/Containers/Internal/StrictPair.hs b/compiler/GHC/Utils/Containers/Internal/StrictPair.hs --- a/compiler/GHC/Utils/Containers/Internal/StrictPair.hs +++ b/compiler/GHC/Utils/Containers/Internal/StrictPair.hs @@ -4,6 +4,11 @@ module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +default () + -- | The same as a regular Haskell pair, but -- -- @ diff --git a/compiler/GHC/Utils/Fingerprint.hs b/compiler/GHC/Utils/Fingerprint.hs --- a/compiler/GHC/Utils/Fingerprint.hs +++ b/compiler/GHC/Utils/Fingerprint.hs @@ -19,6 +19,7 @@ fingerprintFingerprints, fingerprintData, fingerprintString, + fingerprintStrings, getFileHash ) where @@ -43,3 +44,7 @@ fingerprintByteString :: BS.ByteString -> Fingerprint fingerprintByteString bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len + +-- See Note [Repeated -optP hashing] +fingerprintStrings :: [String] -> Fingerprint +fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -1260,7 +1260,7 @@ data JoinPointHood = JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because - | NotJoinPoint -- synonym JoinArity is defined in Types.Basic + | NotJoinPoint -- synonym JoinArity is defined in Types.Basic) deriving( Eq ) isJoinPoint :: JoinPointHood -> Bool diff --git a/compiler/GHC/Utils/TmpFs.hs b/compiler/GHC/Utils/TmpFs.hs --- a/compiler/GHC/Utils/TmpFs.hs +++ b/compiler/GHC/Utils/TmpFs.hs @@ -377,18 +377,27 @@ This is ok, as the temporary directory used contains the pid (see getTempDir). -} + +manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO () +manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths +manyWithTrace logger phase act paths + = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths) + removeTmpDirs :: Logger -> [FilePath] -> IO () -removeTmpDirs logger ds - = traceCmd logger "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith logger removeDirectory) ds) +removeTmpDirs logger + = manyWithTrace logger "Deleting temp dirs" + (mapM_ (removeWith logger removeDirectory)) +removeTmpSubdirs :: Logger -> [FilePath] -> IO () +removeTmpSubdirs logger + = manyWithTrace logger "Deleting temp subdirs" + (mapM_ (removeWith logger removeDirectory)) + removeTmpFiles :: Logger -> [FilePath] -> IO () removeTmpFiles logger fs = warnNon $ - traceCmd logger "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith logger removeFile) deletees) + manyWithTrace logger "Deleting temp files" + (mapM_ (removeWith logger removeFile)) deletees where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source @@ -404,12 +413,6 @@ act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs - -removeTmpSubdirs :: Logger -> [FilePath] -> IO () -removeTmpSubdirs logger fs - = traceCmd logger "Deleting temp subdirs" - ("Deleting: " ++ unwords fs) - (mapM_ (removeWith logger removeDirectory) fs) removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO` diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c --- a/compiler/cbits/genSym.c +++ b/compiler/cbits/genSym.c @@ -9,9 +9,19 @@ // // The CPP is thus about the RTS version GHC is linked against, and not the // version of the GHC being built. -#if !MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) -HsWord64 ghc_unique_counter64 = 0; -#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) + +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +// Unique64 patch was present in 9.10 and later +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) +// Unique64 patch was backported to 9.8.4 +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) +// Unique64 patch was backported to 9.6.7 +#define HAVE_UNIQUE64 1 +#endif + +#if !defined(HAVE_UNIQUE64) HsWord64 ghc_unique_counter64 = 0; #endif #if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal --- a/compiler/ghc.cabal +++ b/compiler/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.10.1 +Version: 9.10.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -109,7 +109,7 @@ deepseq >= 1.4 && < 1.6, directory >= 1 && < 1.4, process >= 1 && < 1.7, - bytestring >= 0.9 && < 0.13, + bytestring >= 0.11 && < 0.13, binary == 0.8.*, time >= 1.4 && < 1.13, containers >= 0.6.2.1 && < 0.8, @@ -121,9 +121,9 @@ exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.10.1, - ghc-heap == 9.10.1, - ghci == 9.10.1 + ghc-boot == 9.10.2, + ghc-heap == 9.10.2, + ghci == 9.10.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 @@ -414,6 +414,7 @@ GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap + GHC.Data.FlatBag GHC.Data.Graph.Base GHC.Data.Graph.Color GHC.Data.Graph.Collapse @@ -828,7 +829,7 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic - GHC.Types.BreakInfo + GHC.Types.Breakpoint GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State 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: 3.0 build-type: Simple name: ghc-lib-parser -version: 9.10.1.20250421 +version: 9.10.2.20250503 license: BSD-3-Clause license-file: LICENSE category: Development @@ -269,6 +269,7 @@ GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap + GHC.Data.FlatBag GHC.Data.Graph.Directed GHC.Data.Graph.UnVar GHC.Data.IOEnv @@ -449,7 +450,7 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic - GHC.Types.BreakInfo + GHC.Types.Breakpoint GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State @@ -560,7 +561,6 @@ GHC.Utils.Trace GHC.Utils.Word64 GHC.Version - GHCi.BinaryArray GHCi.BreakArray GHCi.FFI GHCi.Message diff --git a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs --- a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs @@ -28,4 +28,4 @@ cStage = show (1 :: Int) cProjectUnitId :: String -cProjectUnitId = "ghc-9.10.1-inplace" +cProjectUnitId = "ghc-9.10.2-inplace" diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -11,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv primOpStrictness Control0Op = \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv primOpStrictness AtomicallyOp = \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv primOpStrictness RetryOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -8,6 +8,11 @@ ,("CPP flags", "-E") ,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") +,("JavaScript CPP command", "/usr/local/opt/ccache/libexec/gcc") +,("JavaScript CPP flags", "-E -CC -Wno-unicode -nostdinc") +,("C-- CPP command", "/usr/local/opt/ccache/libexec/gcc") +,("C-- CPP flags", "-E") +,("C-- CPP supports -g0", "YES") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES") ,("ld supports single module", "NO") diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "6d779c0fab30c39475aef50d39064ed67ce839d7" +cProjectGitCommitId = "c9de16b57adcb6810d059ebd1c72d97b4b6a7cec" cProjectVersion :: String -cProjectVersion = "9.10.1" +cProjectVersion = "9.10.2" cProjectVersionInt :: String cProjectVersionInt = "910" cProjectPatchLevel :: String -cProjectPatchLevel = "1" +cProjectPatchLevel = "2" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "1" +cProjectPatchLevel1 = "2" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0" diff --git a/ghc/ghc-bin.cabal b/ghc/ghc-bin.cabal --- a/ghc/ghc-bin.cabal +++ b/ghc/ghc-bin.cabal @@ -2,7 +2,7 @@ -- ./configure. Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal. Name: ghc-bin -Version: 9.10.1 +Version: 9.10.2 Copyright: XXX -- License: XXX -- License-File: XXX @@ -39,8 +39,8 @@ filepath >= 1 && < 1.6, containers >= 0.5 && < 0.8, transformers >= 0.5 && < 0.7, - ghc-boot == 9.10.1, - ghc == 9.10.1 + ghc-boot == 9.10.2, + ghc == 9.10.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 @@ -57,8 +57,8 @@ -- NB: this is never built by the bootstrapping GHC+libraries Build-depends: deepseq >= 1.4 && < 1.6, - ghc-prim >= 0.5.0 && < 0.12, - ghci == 9.10.1, + ghc-prim >= 0.5.0 && < 0.13, + ghci == 9.10.2, haskeline == 0.8.*, exceptions == 0.10.*, time >= 1.8 && < 1.13 diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal b/libraries/ghc-boot-th/ghc-boot-th.cabal --- a/libraries/ghc-boot-th/ghc-boot-th.cabal +++ b/libraries/ghc-boot-th/ghc-boot-th.cabal @@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal. name: ghc-boot-th -version: 9.10.1 +version: 9.10.2 license: BSD3 license-file: LICENSE category: GHC diff --git a/libraries/ghc-boot/ghc-boot.cabal b/libraries/ghc-boot/ghc-boot.cabal --- a/libraries/ghc-boot/ghc-boot.cabal +++ b/libraries/ghc-boot/ghc-boot.cabal @@ -5,7 +5,7 @@ -- ghc-boot.cabal. name: ghc-boot -version: 9.10.1 +version: 9.10.2 license: BSD-3-Clause license-file: LICENSE category: GHC @@ -81,7 +81,7 @@ filepath >= 1.3 && < 1.6, deepseq >= 1.4 && < 1.6, ghc-platform >= 0.1, - ghc-boot-th == 9.10.1 + ghc-boot-th == 9.10.2 if !os(windows) build-depends: unix >= 2.7 && < 2.9 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -35,15 +35,24 @@ import Prelude -- See note [Why do we import Prelude here?] import GHC.Exts.Heap.Constants #if defined(PROFILING) +import GHC.Exts.Heap.InfoTable () -- see Note [No way-dependent imports] import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable +import GHC.Exts.Heap.InfoTableProf () -- see Note [No way-dependent imports] --- `ghc -M` currently doesn't properly account for ways when generating --- dependencies (#15197). This import ensures correct build-ordering between --- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197 --- is fixed. -import GHC.Exts.Heap.InfoTableProf () +{- +Note [No way-dependent imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`ghc -M` currently assumes that the imports for a module are the same +in every way. This is arguably a bug, but breaking this assumption by +importing different things in different ways can cause trouble. For +example, this module in the profiling way imports and uses +GHC.Exts.Heap.InfoTableProf. When it was not also imported in the +vanilla way, there were intermittent build failures due to this module +being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf +in the profiling way. (#15197) +-} #endif import GHC.Exts.Heap.ProfInfo.Types diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs @@ -41,7 +41,11 @@ #if defined(PROFILING) import GHC.Exts.Heap.FFIClosures_ProfilingEnabled as Reexport import GHC.Exts.Heap.FFIClosures_ProfilingDisabled () + -- See Note [No way-dependent imports] in GHC.Exts.Heap.Closures + #else import GHC.Exts.Heap.FFIClosures_ProfilingDisabled as Reexport import GHC.Exts.Heap.FFIClosures_ProfilingEnabled () + -- See Note [No way-dependent imports] in GHC.Exts.Heap.Closures + #endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs --- a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs @@ -7,7 +7,11 @@ #if defined(PROFILING) import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled as Reexport import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled () + -- See Note [No way-dependent imports] in GHC.Exts.Heap.Closures + #else import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled as Reexport import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled () + -- See Note [No way-dependent imports] in GHC.Exts.Heap.Closures + #endif diff --git a/libraries/ghc-heap/ghc-heap.cabal b/libraries/ghc-heap/ghc-heap.cabal --- a/libraries/ghc-heap/ghc-heap.cabal +++ b/libraries/ghc-heap/ghc-heap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-heap -version: 9.10.1 +version: 9.10.2 license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org @@ -23,12 +23,12 @@ default-language: Haskell2010 build-depends: base >= 4.9.0 && < 5.0 - , ghc-prim > 0.2 && < 0.12 + , ghc-prim > 0.2 && < 0.13 , rts == 1.0.* , containers >= 0.6.2.1 && < 0.8 if impl(ghc >= 9.9) - build-depends: ghc-internal >= 9.1001 && < 9.1002 + build-depends: ghc-internal >= 9.900 && < 9.1002.99999 ghc-options: -Wall if !os(ghcjs) diff --git a/libraries/ghci/GHCi/BinaryArray.hs b/libraries/ghci/GHCi/BinaryArray.hs deleted file mode 100644 --- a/libraries/ghci/GHCi/BinaryArray.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-} --- | Efficient serialisation for GHCi Instruction arrays --- --- Author: Ben Gamari --- -module GHCi.BinaryArray(putArray, getArray) where - -import Prelude -import Foreign.Ptr -import Data.Binary -import Data.Binary.Put (putBuilder) -import qualified Data.Binary.Get.Internal as Binary -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Internal as BB -import qualified Data.Array.Base as A -import qualified Data.Array.IO.Internals as A -import qualified Data.Array.Unboxed as A -import GHC.Exts -import GHC.IO - --- | An efficient serialiser of 'A.UArray'. -putArray :: Binary i => A.UArray i a -> Put -putArray (A.UArray l u _ arr#) = do - put l - put u - putBuilder $ byteArrayBuilder arr# - -byteArrayBuilder :: ByteArray# -> BB.Builder -byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#)) - where - go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a - go !inStart !inEnd k (BB.BufferRange outStart outEnd) - -- There is enough room in this output buffer to write all remaining array - -- contents - | inRemaining <= outRemaining = do - copyByteArrayToAddr arr# inStart outStart inRemaining - k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd) - -- There is only enough space for a fraction of the remaining contents - | otherwise = do - copyByteArrayToAddr arr# inStart outStart outRemaining - let !inStart' = inStart + outRemaining - return $! BB.bufferFull 1 outEnd (go inStart' inEnd k) - where - inRemaining = inEnd - inStart - outRemaining = outEnd `minusPtr` outStart - - copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () - copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) = - IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of - s' -> (# s', () #) - --- | An efficient deserialiser of 'A.UArray'. -getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a) -getArray = do - l <- get - u <- get - arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <- - return $ unsafeDupablePerformIO $ A.newArray_ (l,u) - let go 0 _ = return () - go !remaining !off = do - Binary.readNWith n $ \ptr -> - copyAddrToByteArray ptr arr# off n - go (remaining - n) (off + n) - where n = min chunkSize remaining - go (I# (sizeofMutableByteArray# arr#)) 0 - return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr - where - chunkSize = 10*1024 - - copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld - -> Int -> Int -> IO () - copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) = - IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of - s' -> (# s', () #) - --- this is inexplicably not exported in currently released array versions -unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e) -unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr) 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 @@ -23,6 +23,7 @@ , getMessage, putMessage, getTHMessage, putTHMessage , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe , BreakModule + , LoadedDLL ) where import Prelude -- See note [Why do we import Prelude here?] @@ -73,8 +74,9 @@ -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () LookupSymbol :: String -> Message (Maybe (RemotePtr ())) + LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) LookupClosure :: String -> Message (Maybe HValueRef) - LoadDLL :: String -> Message (Maybe String) + LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL)) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? UnloadObj :: String -> Message () -- error? @@ -396,10 +398,12 @@ instance Binary a => Binary (EvalStatus_ a b) -data EvalBreakpoint = - EvalBreakpoint - Int -- ^ break index - String -- ^ ModuleName +data EvalBreakpoint = EvalBreakpoint + { eb_tick_mod :: String -- ^ Breakpoint tick module + , eb_tick_index :: Int -- ^ Breakpoint tick index + , eb_info_mod :: String -- ^ Breakpoint info module + , eb_info_index :: Int -- ^ Breakpoint info index + } deriving (Generic, Show) instance Binary EvalBreakpoint @@ -415,6 +419,9 @@ -- that type isn't available here. data BreakModule +-- | A dummy type that tags pointers returned by 'LoadDLL'. +data LoadedDLL + -- SomeException can't be serialized because it contains dynamic -- types. However, we do very limited things with the exceptions that -- are thrown by interpreted computations: @@ -486,7 +493,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 10 || \ - (major1) == 9 && (major2) == 10 && (minor) <= 1) + (major1) == 9 && (major2) == 10 && (minor) <= 2) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo @@ -550,6 +557,7 @@ 37 -> Msg <$> return RtsRevertCAFs 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (NewBreakModule <$> get) + 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -594,7 +602,8 @@ Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 ResumeSeq a -> putWord8 38 >> put a - NewBreakModule name -> putWord8 39 >> put name + NewBreakModule name -> putWord8 39 >> put name + LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str {- Note [Parallelize CreateBCOs serialization] diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs --- a/libraries/ghci/GHCi/ResolvedBCO.hs +++ b/libraries/ghci/GHCi/ResolvedBCO.hs @@ -1,9 +1,12 @@ {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving, - BangPatterns, CPP #-} + BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts, + TypeApplications, ScopedTypeVariables, UnboxedTuples #-} module GHCi.ResolvedBCO ( ResolvedBCO(..) , ResolvedBCOPtr(..) , isLittleEndian + , BCOByteArray(..) + , mkBCOByteArray ) where import Prelude -- See note [Why do we import Prelude here?] @@ -11,12 +14,20 @@ import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Array.Unboxed import Data.Binary +import Data.Binary.Put (putBuilder) import GHC.Generics -import GHCi.BinaryArray +import Foreign.Ptr +import Data.Array.Byte +import qualified Data.Binary.Get.Internal as Binary +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Internal as BB +import GHC.Exts +import Data.Array.Base (UArray(..)) +import GHC.IO + #include "MachDeps.h" isLittleEndian :: Bool @@ -32,19 +43,35 @@ -- | A 'ResolvedBCO' is one in which all the 'Name' references have been -- resolved to actual addresses or 'RemoteHValues'. -- --- Note, all arrays are zero-indexed (we assume this when --- serializing/deserializing) data ResolvedBCO = ResolvedBCO { resolvedBCOIsLE :: Bool, resolvedBCOArity :: {-# UNPACK #-} !Int, - resolvedBCOInstrs :: UArray Int Word16, -- insns - resolvedBCOBitmap :: UArray Int Word64, -- bitmap - resolvedBCOLits :: UArray Int Word64, -- non-ptrs + resolvedBCOInstrs :: BCOByteArray Word16, -- insns + resolvedBCOBitmap :: BCOByteArray Word, -- bitmap + resolvedBCOLits :: BCOByteArray Word, -- non-ptrs resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs } deriving (Generic, Show) +-- | Wrapper for a 'ByteArray#'. +-- The phantom type tells what elements are stored in the 'ByteArray#'. +-- Creating a 'ByteArray#' can be achieved using 'UArray''s API, +-- where the underlying 'ByteArray#' can be unpacked. +data BCOByteArray a + = BCOByteArray { + getBCOByteArray :: !ByteArray# + } + +mkBCOByteArray :: UArray Int a -> BCOByteArray a +mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr + +instance Show (BCOByteArray Word16) where + showsPrec _ _ = showString "BCOByteArray Word16" + +instance Show (BCOByteArray Word) where + showsPrec _ _ = showString "BCOByteArray Word" + -- | The Binary instance for ResolvedBCOs. -- -- Note, that we do encode the endianness, however there is no support for mixed @@ -54,13 +81,17 @@ put ResolvedBCO{..} = do put resolvedBCOIsLE put resolvedBCOArity - putArray resolvedBCOInstrs - putArray resolvedBCOBitmap - putArray resolvedBCOLits + put resolvedBCOInstrs + put resolvedBCOBitmap + put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO - <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get + get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get +instance Binary (BCOByteArray a) where + put = putBCOByteArray + get = decodeBCOByteArray + + data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int -- ^ reference to the Nth BCO in the current set @@ -75,3 +106,65 @@ deriving (Generic, Show) instance Binary ResolvedBCOPtr + +-- -------------------------------------------------------- +-- Serialisers for 'BCOByteArray' +-- -------------------------------------------------------- + +putBCOByteArray :: BCOByteArray a -> Put +putBCOByteArray (BCOByteArray bar) = do + put (I# (sizeofByteArray# bar)) + putBuilder $ byteArrayBuilder bar + +decodeBCOByteArray :: Get (BCOByteArray a) +decodeBCOByteArray = do + n <- get + getByteArray n + +byteArrayBuilder :: ByteArray# -> BB.Builder +byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#)) + where + go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a + go !inStart !inEnd k (BB.BufferRange outStart outEnd) + -- There is enough room in this output buffer to write all remaining array + -- contents + | inRemaining <= outRemaining = do + copyByteArrayToAddr arr# inStart outStart inRemaining + k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd) + -- There is only enough space for a fraction of the remaining contents + | otherwise = do + copyByteArrayToAddr arr# inStart outStart outRemaining + let !inStart' = inStart + outRemaining + return $! BB.bufferFull 1 outEnd (go inStart' inEnd k) + where + inRemaining = inEnd - inStart + outRemaining = outEnd `minusPtr` outStart + + copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () + copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) = + IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s' -> (# s', () #) + +getByteArray :: Int -> Get (BCOByteArray a) +getByteArray nbytes@(I# nbytes#) = do + let !(MutableByteArray arr#) = unsafeDupablePerformIO $ + IO $ \s -> case newByteArray# nbytes# s of + (# s', mbar #) -> (# s', MutableByteArray mbar #) + let go 0 _ = return () + go !remaining !off = do + Binary.readNWith n $ \ptr -> + copyAddrToByteArray ptr arr# off n + go (remaining - n) (off + n) + where n = min chunkSize remaining + go nbytes 0 + return $! unsafeDupablePerformIO $ + IO $ \s -> case unsafeFreezeByteArray# arr# s of + (# s', bar #) -> (# s', BCOByteArray bar #) + where + chunkSize = 10*1024 + + copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld + -> Int -> Int -> IO () + copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) = + IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s' -> (# s', () #) diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal --- a/libraries/ghci/ghci.cabal +++ b/libraries/ghci/ghci.cabal @@ -2,7 +2,7 @@ -- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. name: ghci -version: 9.10.1 +version: 9.10.2 license: BSD3 license-file: LICENSE category: GHC @@ -76,14 +76,14 @@ rts, array == 0.5.*, base >= 4.8 && < 4.21, - ghc-prim >= 0.5.0 && < 0.12, + ghc-prim >= 0.5.0 && < 0.13, binary == 0.8.*, bytestring >= 0.10 && < 0.13, containers >= 0.5 && < 0.8, deepseq >= 1.4 && < 1.6, filepath >= 1.4 && < 1.6, - ghc-boot == 9.10.1, - ghc-heap == 9.10.1, + ghc-boot == 9.10.2, + ghc-heap == 9.10.2, template-haskell == 2.22.*, transformers >= 0.5 && < 0.7 diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -56,7 +56,7 @@ build-depends: base >= 4.11 && < 4.21, - ghc-boot-th == 9.10.1, + ghc-boot-th == 9.10.2, ghc-prim, pretty == 1.1.*