ghc-lib-parser 9.10.1.20250421 → 9.10.2.20250503
raw patch · 84 files changed
+1440/−611 lines, 84 filesdep ~ghc-prim
Dependency ranges changed: ghc-prim
Files
- compiler/GHC/Builtin/Names.hs +7/−9
- compiler/GHC/Builtin/PrimOps.hs-boot +2/−1
- compiler/GHC/Builtin/Types.hs +142/−74
- compiler/GHC/Builtin/Types/Prim.hs +5/−2
- compiler/GHC/ByteCode/Types.hs +12/−8
- compiler/GHC/Core/Map/Type.hs +1/−1
- compiler/GHC/Core/Opt/Arity.hs +3/−3
- compiler/GHC/Core/Opt/ConstantFold.hs +15/−5
- compiler/GHC/Core/Opt/OccurAnal.hs +144/−100
- compiler/GHC/Core/Opt/Simplify/Iteration.hs +27/−14
- compiler/GHC/Core/TyCo/Compare.hs +107/−48
- compiler/GHC/Core/TyCo/Ppr.hs +8/−7
- compiler/GHC/Core/TyCo/Rep.hs +19/−4
- compiler/GHC/Core/TyCo/Subst.hs +1/−1
- compiler/GHC/Core/Type.hs +2/−0
- compiler/GHC/Core/Unify.hs +1/−1
- compiler/GHC/Core/Utils.hs +1/−1
- compiler/GHC/Data/FlatBag.hs +129/−0
- compiler/GHC/Data/SmallArray.hs +57/−2
- compiler/GHC/Data/Word64Map/Strict.hs +0/−1
- compiler/GHC/Driver/CmdLine.hs +1/−1
- compiler/GHC/Driver/Config/Diagnostic.hs +1/−1
- compiler/GHC/Driver/DynFlags.hs +2/−0
- compiler/GHC/Driver/Errors/Ppr.hs +4/−4
- compiler/GHC/Driver/Flags.hs +5/−0
- compiler/GHC/Driver/Hooks.hs +0/−2
- compiler/GHC/Driver/Plugins.hs +6/−6
- compiler/GHC/Driver/Session.hs +57/−8
- compiler/GHC/Hs/Type.hs +47/−0
- compiler/GHC/Iface/Errors/Ppr.hs +1/−1
- compiler/GHC/Iface/Syntax.hs +1/−1
- compiler/GHC/Iface/Type.hs +1/−1
- compiler/GHC/Iface/Type.hs-boot +1/−1
- compiler/GHC/Linker/Types.hs +54/−4
- compiler/GHC/Parser/PostProcess.hs +0/−1
- compiler/GHC/Platform.hs +1/−1
- compiler/GHC/Runtime/Eval/Types.hs +11/−13
- compiler/GHC/Runtime/Interpreter/Types.hs +3/−3
- compiler/GHC/Settings.hs +32/−1
- compiler/GHC/StgToCmm/Config.hs +3/−0
- compiler/GHC/StgToJS/Types.hs +1/−1
- compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot +3/−0
- compiler/GHC/Tc/Errors/Ppr.hs +71/−15
- compiler/GHC/Tc/Errors/Types.hs +1/−2
- compiler/GHC/Tc/Types.hs +4/−0
- compiler/GHC/Tc/Types/Constraint.hs +59/−23
- compiler/GHC/Tc/Types/Evidence.hs +13/−13
- compiler/GHC/Tc/Types/LclEnv.hs-boot +3/−0
- compiler/GHC/Tc/Utils/TcType.hs +16/−3
- compiler/GHC/Types/BreakInfo.hs +0/−12
- compiler/GHC/Types/Breakpoint.hs +53/−0
- compiler/GHC/Types/Demand.hs +23/−13
- compiler/GHC/Types/Id.hs +21/−16
- compiler/GHC/Types/Id.hs-boot +0/−1
- compiler/GHC/Types/Id/Info.hs +16/−5
- compiler/GHC/Types/Id/Make.hs +14/−16
- compiler/GHC/Types/Name/Ppr.hs +2/−1
- compiler/GHC/Types/RepType.hs +3/−0
- compiler/GHC/Types/Var.hs +1/−1
- compiler/GHC/Types/Var.hs-boot +0/−6
- compiler/GHC/Unit/Types.hs +1/−1
- compiler/GHC/Utils/Containers/Internal/StrictPair.hs +5/−0
- compiler/GHC/Utils/Fingerprint.hs +5/−0
- compiler/GHC/Utils/Outputable.hs +1/−1
- compiler/GHC/Utils/TmpFs.hs +16/−13
- compiler/cbits/genSym.c +13/−3
- compiler/ghc.cabal +7/−6
- ghc-lib-parser.cabal +3/−3
- ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +1/−1
- ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +1/−1
- ghc-lib/stage0/lib/settings +5/−0
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- ghc/ghc-bin.cabal +5/−5
- libraries/ghc-boot-th/ghc-boot-th.cabal +1/−1
- libraries/ghc-boot/ghc-boot.cabal +2/−2
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +14/−5
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs +4/−0
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs +4/−0
- libraries/ghc-heap/ghc-heap.cabal +3/−3
- libraries/ghci/GHCi/BinaryArray.hs +0/−78
- libraries/ghci/GHCi/Message.hs +16/−7
- libraries/ghci/GHCi/ResolvedBCO.hs +106/−13
- libraries/ghci/ghci.cabal +4/−4
- libraries/template-haskell/template-haskell.cabal +1/−1
compiler/GHC/Builtin/Names.hs view
@@ -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
compiler/GHC/Builtin/PrimOps.hs-boot view
@@ -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
compiler/GHC/Builtin/Types.hs view
@@ -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
compiler/GHC/Builtin/Types/Prim.hs view
@@ -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]
compiler/GHC/ByteCode/Types.hs view
@@ -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" <+>
compiler/GHC/Core/Map/Type.hs view
@@ -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
compiler/GHC/Core/Opt/Arity.hs view
@@ -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 {- ************************************************************************
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -2660,6 +2660,10 @@ inline f_ty (f a b c) = <f's unfolding> 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) = <f's unfolding> a b c |> co+ inline f_ty <tick> ( f a b c ) = <tick> <f's unfolding> 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 (<tick> f)+ go (Tick t e) = do { app <- go e; pure (Tick t app) }+ go _ = Nothing match_inline _ = Nothing
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -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
compiler/GHC/Core/Opt/Simplify/Iteration.hs view
@@ -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 }
compiler/GHC/Core/TyCo/Compare.hs view
@@ -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
compiler/GHC/Core/TyCo/Ppr.hs view
@@ -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
compiler/GHC/Core/TyCo/Rep.hs view
@@ -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]
compiler/GHC/Core/TyCo/Subst.hs view
@@ -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
compiler/GHC/Core/Type.hs view
@@ -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
compiler/GHC/Core/Unify.hs view
@@ -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 ()
compiler/GHC/Core/Utils.hs view
@@ -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
+ compiler/GHC/Data/FlatBag.hs view
@@ -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)
compiler/GHC/Data/SmallArray.hs view
@@ -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
compiler/GHC/Data/Word64Map/Strict.hs view
@@ -248,4 +248,3 @@ ) where import GHC.Data.Word64Map.Strict.Internal-import Prelude ()
compiler/GHC/Driver/CmdLine.hs view
@@ -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
compiler/GHC/Driver/Config/Diagnostic.hs view
@@ -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
compiler/GHC/Driver/DynFlags.hs view
@@ -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
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -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
compiler/GHC/Driver/Flags.hs view
@@ -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
compiler/GHC/Driver/Hooks.hs view
@@ -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
compiler/GHC/Driver/Plugins.hs view
@@ -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 ()
compiler/GHC/Driver/Session.hs view
@@ -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,
compiler/GHC/Hs/Type.hs view
@@ -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
compiler/GHC/Iface/Errors/Ppr.hs view
@@ -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
compiler/GHC/Iface/Syntax.hs view
@@ -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,
compiler/GHC/Iface/Type.hs view
@@ -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,
compiler/GHC/Iface/Type.hs-boot view
@@ -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
compiler/GHC/Linker/Types.hs view
@@ -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. --
compiler/GHC/Parser/PostProcess.hs view
@@ -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(..) )
compiler/GHC/Platform.hs view
@@ -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
compiler/GHC/Runtime/Eval/Types.hs view
@@ -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+ }
compiler/GHC/Runtime/Interpreter/Types.hs view
@@ -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
compiler/GHC/Settings.hs view
@@ -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]
compiler/GHC/StgToCmm/Config.hs view
@@ -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
compiler/GHC/StgToJS/Types.hs view
@@ -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
compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot view
@@ -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
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -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
compiler/GHC/Tc/Errors/Types.hs view
@@ -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
compiler/GHC/Tc/Types.hs view
@@ -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.
compiler/GHC/Tc/Types/Constraint.hs view
@@ -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. --
compiler/GHC/Tc/Types/Evidence.hs view
@@ -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). <res>_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
compiler/GHC/Tc/Types/LclEnv.hs-boot view
@@ -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
compiler/GHC/Tc/Utils/TcType.hs view
@@ -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 '()'.
− compiler/GHC/Types/BreakInfo.hs
@@ -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- }
+ compiler/GHC/Types/Breakpoint.hs view
@@ -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.
compiler/GHC/Types/Demand.hs view
@@ -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:
compiler/GHC/Types/Id.hs view
@@ -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
compiler/GHC/Types/Id.hs-boot view
@@ -1,6 +1,5 @@ module GHC.Types.Id where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name import {-# SOURCE #-} GHC.Types.Var
compiler/GHC/Types/Id/Info.hs view
@@ -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)})
compiler/GHC/Types/Id/Make.hs view
@@ -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.
compiler/GHC/Types/Name/Ppr.hs view
@@ -123,7 +123,8 @@ , fUNTyConName, unrestrictedFunTyConName , oneDataConName , listTyConName- , manyDataConName ]+ , manyDataConName+ , soloDataConName ] || isJust (isTupleTyOcc_maybe mod occ) || isJust (isSumTyOcc_maybe mod occ)
compiler/GHC/Types/RepType.hs view
@@ -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
compiler/GHC/Types/Var.hs view
@@ -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
compiler/GHC/Types/Var.hs-boot view
@@ -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
compiler/GHC/Unit/Types.hs view
@@ -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
compiler/GHC/Utils/Containers/Internal/StrictPair.hs view
@@ -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 -- -- @
compiler/GHC/Utils/Fingerprint.hs view
@@ -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
compiler/GHC/Utils/Outputable.hs view
@@ -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
compiler/GHC/Utils/TmpFs.hs view
@@ -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`
compiler/cbits/genSym.c view
@@ -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)
compiler/ghc.cabal view
@@ -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
ghc-lib-parser.cabal view
@@ -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
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -28,4 +28,4 @@ cStage = show (1 :: Int) cProjectUnitId :: String-cProjectUnitId = "ghc-9.10.1-inplace"+cProjectUnitId = "ghc-9.10.2-inplace"
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -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
ghc-lib/stage0/lib/settings view
@@ -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")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "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"
ghc/ghc-bin.cabal view
@@ -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
libraries/ghc-boot-th/ghc-boot-th.cabal view
@@ -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
libraries/ghc-boot/ghc-boot.cabal view
@@ -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
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -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
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs view
@@ -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
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs view
@@ -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
libraries/ghc-heap/ghc-heap.cabal view
@@ -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)
− libraries/ghci/GHCi/BinaryArray.hs
@@ -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)
libraries/ghci/GHCi/Message.hs view
@@ -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]
libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -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', () #)
libraries/ghci/ghci.cabal view
@@ -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
libraries/template-haskell/template-haskell.cabal view
@@ -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.*