diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -157,14 +157,14 @@ -- ** The debugger SingleStep(..), Resume(..), - History(historyBreakInfo, historyEnclosingDecls), + History(historyBreakpointId, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, abandon, abandonAll, getResumeContext, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, - BreakInfo(..), + BreakpointId(..), InternalBreakpointId(..), GHC.Runtime.Eval.back, GHC.Runtime.Eval.forward, GHC.Runtime.Eval.setupBreakpoint, @@ -337,6 +337,7 @@ import GHC.Parser.Annotation import GHC.Parser.Utils +import GHC.Iface.Env ( trace_if ) import GHC.Iface.Load ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars ) @@ -392,8 +393,9 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv -import GHC.Types.BreakInfo +import GHC.Types.Breakpoint import GHC.Types.PkgQual +import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.Env @@ -673,6 +675,7 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger + lookup_cache <- liftIO $ newMVar emptyUFM -- Interpreter interp <- if @@ -702,7 +705,7 @@ } s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader)) + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) -- JavaScript interpreter | ArchJavaScript <- platformArch (targetPlatform dflags) @@ -720,7 +723,7 @@ , jsInterpFinderOpts = initFinderOpts dflags , jsInterpFinderCache = hsc_FC hsc_env } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader)) + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) -- Internal interpreter | otherwise @@ -728,7 +731,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader)) + return (Just (Interp InternalInterp loader lookup_cache)) #else return Nothing #endif @@ -1701,6 +1704,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do + liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) let mhome_unit = hsc_home_unit_maybe hsc_env let dflags = hsc_dflags hsc_env case pkgqual of @@ -1763,7 +1767,8 @@ lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module) -lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> +lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> do + liftIO $ trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid) case lookupHug (hsc_HUG hsc_env) uid mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs --- a/GHC/Builtin/Names.hs +++ b/GHC/Builtin/Names.hs @@ -276,7 +276,7 @@ -- Dynamic toDynName, - -- GHC.Internal.Numeric stuff + -- Numeric stuff negateName, minusName, geName, eqName, mkRationalBase2Name, mkRationalBase10Name, @@ -430,7 +430,6 @@ naturalPowModName, naturalSizeInBaseName, - bignatFromWordListName, bignatEqName, -- Float/Double @@ -1203,7 +1202,6 @@ , naturalLogBaseName , naturalPowModName , naturalSizeInBaseName - , bignatFromWordListName , bignatEqName , bignatCompareName , bignatCompareWordName @@ -1215,7 +1213,6 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key -- Types and DataCons -bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey @@ -2010,6 +2007,12 @@ unsatisfiableClassNameKey :: Unique unsatisfiableClassNameKey = mkPreludeTyConUnique 170 +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 171 + +zonkAnyTyConKey :: Unique +zonkAnyTyConKey = mkPreludeTyConUnique 172 + -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 @@ -2023,9 +2026,6 @@ specTyConKey :: Unique specTyConKey = mkPreludeTyConUnique 185 -anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 186 - smallArrayPrimTyConKey = mkPreludeTyConUnique 187 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 @@ -2641,7 +2641,6 @@ , naturalLogBaseIdKey , naturalPowModIdKey , naturalSizeInBaseIdKey - , bignatFromWordListIdKey , bignatEqIdKey , bignatCompareIdKey , bignatCompareWordIdKey @@ -2709,7 +2708,6 @@ naturalPowModIdKey = mkPreludeMiscIdUnique 683 naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 -bignatFromWordListIdKey = mkPreludeMiscIdUnique 690 bignatEqIdKey = mkPreludeMiscIdUnique 691 bignatCompareIdKey = mkPreludeMiscIdUnique 692 bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 diff --git a/GHC/Builtin/PrimOps.hs-boot b/GHC/Builtin/PrimOps.hs-boot --- a/GHC/Builtin/PrimOps.hs-boot +++ b/GHC/Builtin/PrimOps.hs-boot @@ -1,5 +1,6 @@ module GHC.Builtin.PrimOps where -import GHC.Prelude () +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () data PrimOp diff --git a/GHC/Builtin/Types.hs b/GHC/Builtin/Types.hs --- a/GHC/Builtin/Types.hs +++ b/GHC/Builtin/Types.hs @@ -78,6 +78,7 @@ promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, soloTyCon, + soloDataConName, pairTyCon, mkPromotedPairTy, isPromotedPairType, unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, @@ -91,7 +92,7 @@ cTupleSelId, cTupleSelIdName, -- * Any - anyTyCon, anyTy, anyTypeOfKind, + anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon, -- * Recovery TyCon makeRecoveryTyCon, @@ -184,7 +185,7 @@ import GHC.Core.TyCon import GHC.Core.Class ( Class, mkClass ) import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) -import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) +import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) ) import GHC.Types.TyThing import GHC.Types.SourceText @@ -309,6 +310,7 @@ , soloTyCon , anyTyCon + , zonkAnyTyCon , boolTyCon , charTyCon , stringTyCon @@ -419,58 +421,107 @@ {- Note [Any types] ~~~~~~~~~~~~~~~~ -The type constructor Any, +The type constructors `Any` and `ZonkAny` are closed type families declared thus: - type family Any :: k where { } + type family Any :: forall k. k where { } + type family ZonkAny :: forall k. Nat -> k where { } -It has these properties: +They are used when we want a type of a particular kind, but we don't really care +what that type is. The leading example is this: `ZonkAny` is used to instantiate +un-constrained type variables after type checking. For example, consider the +term (length [] :: Int), where - * Note that 'Any' is kind polymorphic since in some program we may - need to use Any to fill in a type variable of some kind other than * - (see #959 for examples). Its kind is thus `forall k. k``. + length :: forall a. [a] -> Int + [] :: forall a. [a] - * It is defined in module GHC.Types, and exported so that it is - available to users. For this reason it's treated like any other - wired-in type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache +We must type-apply `length` and `[]`, but to what type? It doesn't matter! +The typechecker will end up with - * It is a *closed* type family, with no instances. This means that - if ty :: '(k1, k2) we add a given coercion - g :: ty ~ (Fst ty, Snd ty) - If Any was a *data* type, then we'd get inconsistency because 'ty' - could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other. See also #9097 and #9636. + length @alpha ([] @alpha) - * When instantiated at a lifted type it is inhabited by at least one value, - namely bottom +where `alpha` is an un-constrained unification variable. The "zonking" process zaps +that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is +arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`. +So we end up with - * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3)) - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. +`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see +wrinkle (Any4). - * It is wired-in so we can easily refer to it where we don't have a name - environment (e.g. see Rules.matchRule for one example) +Wrinkles: -It's used to instantiate un-constrained type variables after type checking. For -example, 'length' has type +(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may + need to use `ZonkAny` to fill in a type variable of some kind other than * + (see #959 for examples). - length :: forall a. [a] -> Int +(Any2) They are /closed/ type families, with no instances. For example, suppose that + with alpha :: '(k1, k2) we add a given coercion + g :: alpha ~ (Fst alpha, Snd alpha) + and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type, + we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one + side and '(,) on the other. See also #9097 and #9636. -and the list datacon for the empty list has type + See #25244 for a suggestion that we instead use an /open/ type family for which + you cannot provide instances. Probably the difference is not very important. - [] :: forall a. [a] +(Any3) They do not claim to be /data/ types, and that's important for + the code generator, because the code gen may /enter/ a data value + but never enters a function value. -In order to compose these two terms as @length []@ a type -application is required, but there is no constraint on the -choice. In this situation GHC uses 'Any', +(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/ + types (#24817). Consider -> length @(Any @Type) ([] @(Any @Type)) + data SBool a where { STrue :: SBool True; SFalse :: SBool False } -Above, we print kinds explicitly, as if with -fprint-explicit-kinds. + foo :: forall a b. (SBool a, SBool b) + bar :: Bool + bar = case foo @alpha @beta of + (STrue, SFalse) -> True -- This branch is not inaccessible! + _ -> False + + Now, what are `alpha` and `beta`? If we zonk both of them to the same type + `Any @Type`, the pattern-match checker will (wrongly) report that the first + branch is inaccessible. So we zonk them to two /different/ types: + alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5 + (The actual numbers are arbitrary; they just need to differ.) + + The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and + `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to + make up a fresh type. + + If this example seems unconvincing (e.g. in this case foo must be bottom) + see #24817 for larger but more compelling examples. + +(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we + don't have a name environment (e.g. see Rules.matchRule for one example) + +(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that + it is available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + Currently `ZonkAny` is not available to users; but it could easily be. + +(Any7) Properties of `Any`: + * When `Any` is instantiated at a lifted type it is inhabited by at least one value, + namely bottom. + + * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`. + + * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`. + + * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when + the kinds of both the type and `Any` match. + + * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over + `unsafeCoerce#` as they prevent accidentally coercing between types with kinds + that don't match. + + See examples in ghc-prim:GHC.Types + The Any tycon used to be quite magic, but we have since been able to implement it merely with an empty kind polymorphic type family. See #10886 for a bit of history. @@ -482,6 +533,7 @@ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon anyTyCon :: TyCon +-- See Note [Any types] anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing (ClosedSynFamilyTyCon Nothing) Nothing @@ -496,6 +548,24 @@ anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkTyConApp anyTyCon [kind] +zonkAnyTyConName :: Name +zonkAnyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon + +zonkAnyTyCon :: TyCon +-- ZonkAnyTyCon :: forall k. Nat -> k +-- See Note [Any types] +zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName + [ mkNamedTyConBinder Specified kv + , mkAnonTyConBinder nat_kv ] + (mkTyVarTy kv) + Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy] + -- | Make a fake, recovery 'TyCon' from an existing one. -- Used when recovering from errors in type declarations makeRecoveryTyCon :: TyCon -> TyCon @@ -827,7 +897,6 @@ ":" -> Just consDataConName -- function tycon - "FUN" -> Just fUNTyConName "->" -> Just unrestrictedFunTyConName -- tuple data/tycon @@ -986,40 +1055,36 @@ isCTupleOcc_maybe mod occ <|> isSumTyOcc_maybe mod occ -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName --- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ns ar) -mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ns ar) +mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax) +mkTupleOcc ns b ar = (mkOccName ns str, built_in) + where (str, built_in) = mkTupleStr' ns b ar mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) mkTupleStr :: Boxity -> NameSpace -> Arity -> String -mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = mkUnboxedTupleStr - -mkBoxedTupleStr :: NameSpace -> Arity -> String -mkBoxedTupleStr ns 0 - | isDataConNameSpace ns = "()" - | otherwise = "Unit" -mkBoxedTupleStr ns 1 - | isDataConNameSpace ns = "MkSolo" -- See Note [One-tuples] - | otherwise = "Solo" -mkBoxedTupleStr ns ar - | isDataConNameSpace ns = '(' : commas ar ++ ")" - | otherwise = "Tuple" ++ showInt ar "" - +mkTupleStr b ns ar = str + where (str, _) = mkTupleStr' ns b ar -mkUnboxedTupleStr :: NameSpace -> Arity -> String -mkUnboxedTupleStr ns 0 - | isDataConNameSpace ns = "(##)" - | otherwise = "Unit#" -mkUnboxedTupleStr ns 1 - | isDataConNameSpace ns = "(# #)" -- See Note [One-tuples] - | otherwise = "Solo#" -mkUnboxedTupleStr ns ar - | isDataConNameSpace ns = "(#" ++ commas ar ++ "#)" - | otherwise = "Tuple" ++ show ar ++ "#" +mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax) +mkTupleStr' ns Boxed 0 + | isDataConNameSpace ns = ("()", BuiltInSyntax) + | otherwise = ("Unit", UserSyntax) +mkTupleStr' ns Boxed 1 + | isDataConNameSpace ns = ("MkSolo", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo", UserSyntax) +mkTupleStr' ns Boxed ar + | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax) + | otherwise = ("Tuple" ++ showInt ar "", UserSyntax) +mkTupleStr' ns Unboxed 0 + | isDataConNameSpace ns = ("(##)", BuiltInSyntax) + | otherwise = ("Unit#", UserSyntax) +mkTupleStr' ns Unboxed 1 + | isDataConNameSpace ns = ("(# #)", BuiltInSyntax) -- See Note [One-tuples] + | otherwise = ("Solo#", UserSyntax) +mkTupleStr' ns Unboxed ar + | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax) + | otherwise = ("Tuple" ++ show ar ++ "#", UserSyntax) mkConstraintTupleStr :: Arity -> String mkConstraintTupleStr 0 = "CUnit" @@ -1175,10 +1240,10 @@ boxity = Boxed modu = gHC_INTERNAL_TUPLE - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) UserSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity @@ -1209,10 +1274,10 @@ boxity = Unboxed modu = gHC_TYPES - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) UserSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity @@ -1275,6 +1340,9 @@ soloTyConName :: Name soloTyConName = tyConName soloTyCon + +soloDataConName :: Name +soloDataConName = tupleDataConName Boxed 1 pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 diff --git a/GHC/Builtin/Types/Prim.hs b/GHC/Builtin/Types/Prim.hs --- a/GHC/Builtin/Types/Prim.hs +++ b/GHC/Builtin/Types/Prim.hs @@ -63,7 +63,8 @@ doublePrimTyCon, doublePrimTy, doublePrimTyConName, statePrimTyCon, mkStatePrimTy, - realWorldTyCon, realWorldTy, realWorldStatePrimTy, + realWorldTyCon, realWorldTy, + realWorldStatePrimTy, realWorldMutableByteArrayPrimTy, proxyPrimTyCon, mkProxyPrimTy, @@ -1178,7 +1179,9 @@ realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld - +realWorldMutableByteArrayPrimTy :: Type +realWorldMutableByteArrayPrimTy + = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] diff --git a/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp --- a/GHC/Builtin/primops.txt.pp +++ b/GHC/Builtin/primops.txt.pp @@ -2630,18 +2630,45 @@ section "Exceptions" ------------------------------------------------------------------------ --- Note [Strictness for mask/unmask/catch] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Note [Strict IO wrappers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- Consider this example, which comes from GHC.IO.Handle.Internals: --- wantReadableHandle3 f ma b st +-- wantReadableHandle3 f mv b st -- = case ... of --- DEFAULT -> case ma of MVar a -> ... --- 0# -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...) +-- DEFAULT -> case mv of MVar a -> ... +-- 0# -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...) -- The outer case just decides whether to mask exceptions, but we don't want --- thereby to hide the strictness in 'ma'! Hence the use of strictOnceApply1Dmd --- in mask and unmask. But catch really is lazy in its first argument, see --- #11555. So for IO actions 'ma' we often use a wrapper around it that is --- head-strict in 'ma': GHC.IO.catchException. +-- thereby to hide the strictness in `mv`! Hence the use of strictOnceApply1Dmd +-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect +-- that it potentially calls its action multiple times). +-- +-- Note [Strictness for catch-style primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The catch#-style primops always call their action, just like outlined +-- in Note [Strict IO wrappers]. +-- However, it is important that we give their first arg lazyApply1Dmd and not +-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call +-- +-- catch# act handler s +-- +-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that +-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and +-- Note [Precise exceptions and strictness analysis]). +-- This would cause dead code elimination to discard the continuation of the +-- catch# call, among other things. This first came up in #11555. +-- +-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag +-- from `act`. (This is a bit brutal, but the language of strictness types is +-- not expressive enough to give it a more precise semantics that is still +-- sound.) +-- For perf reasons we often (but not always) choose to use a wrapper around +-- catch# that is head-strict in `act`: GHC.IO.catchException. +-- +-- A similar caveat applies to prompt#, which can be seen as a +-- generalisation of catch# as explained in GHC.Prim#continuations#. +-- The reason is that even if `act` appears dead-ending (e.g., looping) +-- `prompt# tag ma s` might return alright due to a (higher-order) use of +-- `control0#` in `act`. This came up in #25439. primop CatchOp "catch#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a_reppoly #) ) @@ -2658,7 +2685,7 @@ strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strictness for catch-style primops] out_of_line = True effect = ReadWriteEffect -- Either inner computation might potentially raise an unchecked exception, @@ -2724,7 +2751,7 @@ in continuation-style primops\" for details. } with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strict IO wrappers] out_of_line = True effect = ReadWriteEffect @@ -2739,6 +2766,7 @@ in continuation-style primops\" for details. } with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] out_of_line = True effect = ReadWriteEffect @@ -2753,7 +2781,7 @@ in continuation-style primops\" for details. } with strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strict IO wrappers] out_of_line = True effect = ReadWriteEffect @@ -2939,7 +2967,8 @@ -> State# RealWorld -> (# State# RealWorld, a #) { See "GHC.Prim#continuations". } with - strictness = { \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv } + -- See Note [Strictness for catch-style primops] out_of_line = True effect = ReadWriteEffect @@ -2967,7 +2996,7 @@ -> State# RealWorld -> (# State# RealWorld, a_levpoly #) with strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strict IO wrappers] out_of_line = True effect = ReadWriteEffect @@ -2996,7 +3025,7 @@ strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply1Dmd , topDmd ] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strictness for catch-style primops] out_of_line = True effect = ReadWriteEffect @@ -3008,7 +3037,7 @@ strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd ] topDiv } - -- See Note [Strictness for mask/unmask/catch] + -- See Note [Strictness for catch-style primops] out_of_line = True effect = ReadWriteEffect @@ -3695,6 +3724,7 @@ with out_of_line = True strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } + -- See Note [Strict IO wrappers] effect = ReadWriteEffect -- The invoked computation may have side effects diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs --- a/GHC/ByteCode/Asm.hs +++ b/GHC/ByteCode/Asm.hs @@ -71,9 +71,9 @@ where bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) = unionManyUniqDSets ( - mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : - mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : - map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] + mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ] ) -- ----------------------------------------------------------------------------- @@ -213,9 +213,9 @@ (text "bytecode instruction count mismatch") let asm_insns = ssElts final_insns - insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns - bitmap_arr = mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs + !insns_arr = mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns + !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs) -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until @@ -224,7 +224,7 @@ return ul_bco -mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64 +mkBitmapArray :: Word -> [StgWord] -> UArray Int Word -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component -- of a BCO object. @@ -513,11 +513,16 @@ CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit bci_PRIMCALL [] - BRK_FUN arr index mod cc -> do p1 <- ptr (BCOPtrBreakArray arr) - m <- addr mod + BRK_FUN arr tick_mod tickx info_mod infox cc -> + do p1 <- ptr (BCOPtrBreakArray arr) + tick_addr <- addr tick_mod + info_addr <- addr info_mod np <- addr cc - emit bci_BRK_FUN [Op p1, SmallOp index, - Op m, Op np] + emit bci_BRK_FUN [ Op p1 + , Op tick_addr, Op info_addr + , SmallOp tickx, SmallOp infox + , Op np + ] where literal (LitLabel fs (Just sz) _) diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs --- a/GHC/ByteCode/Instr.hs +++ b/GHC/ByteCode/Instr.hs @@ -83,7 +83,7 @@ | PUSH16_W !ByteOff | PUSH32_W !ByteOff - -- Push a ptr (these all map to PUSH_G really) + -- Push a (heap) ptr (these all map to PUSH_G really) | PUSH_G Name | PUSH_PRIMOP PrimOp | PUSH_BCO (ProtoBCO Name) @@ -206,7 +206,11 @@ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN (ForeignRef BreakArray) !Word16 (RemotePtr ModuleName) + | BRK_FUN (ForeignRef BreakArray) + (RemotePtr ModuleName) -- breakpoint tick module + !Word16 -- breakpoint tick index + (RemotePtr ModuleName) -- breakpoint info module + !Word16 -- breakpoint info index (RemotePtr CostCentre) -- ----------------------------------------------------------------------------- @@ -358,8 +362,11 @@ ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN _ index _ _) = text "BRK_FUN" <+> text "" - <+> ppr index <+> text "" <+> text "" + ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _) + = text "BRK_FUN" <+> text "" + <+> text "" <+> ppr tickx + <+> text "" <+> ppr infox + <+> text "" diff --git a/GHC/ByteCode/Linker.hs b/GHC/ByteCode/Linker.hs --- a/GHC/ByteCode/Linker.hs +++ b/GHC/ByteCode/Linker.hs @@ -24,6 +24,7 @@ import GHCi.ResolvedBCO import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names import GHC.Unit.Types @@ -38,6 +39,8 @@ import GHC.Types.Name import GHC.Types.Name.Env +import qualified GHC.Types.Id as Id +import GHC.Types.Unique.DFM import Language.Haskell.Syntax.Module.Name @@ -52,31 +55,35 @@ linkBCO :: Interp + -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp le bco_ix +linkBCO interp pkgs_loaded le bco_ix (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. - lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0) - ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0) - return (ResolvedBCO isLittleEndian arity insns bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0) + let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits + return (ResolvedBCO isLittleEndian arity + insns + bitmap + (mkBCOByteArray lits') (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word -lookupLiteral interp le ptr = case ptr of +lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded le ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp (itbl_env le) nm + Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do - Ptr a# <- lookupAddr interp (addr_env le) nm + Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrStr _ -> -- should be eliminated during assembleBCOs @@ -90,19 +97,19 @@ Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" (unpackFS addr_of_label_string) -lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE interp ie con_nm = +lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) +lookupIE interp pkgs_loaded ie con_nm = case lookupNameEnv ie con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupSymbol interp sym_to_find1 + m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info" case m of Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupSymbol interp sym_to_find2 + n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info" case n of Just addr -> return addr Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" @@ -110,34 +117,35 @@ unpackFS sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode -lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ()) -lookupAddr interp ae addr_nm = do +lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded ae addr_nm = do case lookupNameEnv ae addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. let sym_to_find = nameToCLabel addr_nm "bytes" -- see Note [Bytes label] in GHC.Cmm.CLabel - m <- lookupSymbol interp sym_to_find + m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes" case m of Just ptr -> return ptr Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" (unpackFS sym_to_find) -lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ()) -lookupPrimOp interp primop = do +lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp interp pkgs_loaded primop = do let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol interp (mkFastString sym_to_find) + m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure" case m of Just p -> return (toRemotePtr p) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find resolvePtr :: Interp + -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp le bco_ix ptr = case ptr of +resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group @@ -149,19 +157,41 @@ -> assertPpr (isExternalName nm) (ppr nm) $ do let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol interp sym_to_find + m <- lookupHsSymbol interp pkgs_loaded nm "closure" case m of Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) BCOPtrPrimOp op - -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op + -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco BCOPtrBreakArray breakarray -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba) + +-- | Look up the address of a Haskell symbol in the currently +-- loaded units. +-- +-- See Note [Looking up symbols in the relevant objects]. +lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ())) +lookupHsSymbol interp pkgs_loaded nm sym_suffix = do + massertPpr (isExternalName nm) (ppr nm) + let sym_to_find = nameToCLabel nm sym_suffix + pkg_id = moduleUnitId $ nameModule nm + loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id + + go (dll:dlls) = do + mb_ptr <- lookupSymbolInDLL interp dll sym_to_find + case mb_ptr of + Just ptr -> pure (Just ptr) + Nothing -> go dlls + go [] = + -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types + lookupSymbol interp sym_to_find + + go loaded_dlls linkFail :: String -> String -> IO a linkFail who what diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs --- a/GHC/ByteCode/Types.hs +++ b/GHC/ByteCode/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedNewtypes #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -8,6 +10,7 @@ -- | Bytecode assembler types module GHC.ByteCode.Types ( CompiledByteCode(..), seqCompiledByteCode + , BCOByteArray(..), mkBCOByteArray , FFIInfo(..) , RegBitmap(..) , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo @@ -18,12 +21,13 @@ , CgBreakInfo(..) , ModBreaks (..), BreakIndex, emptyModBreaks , CCostCentre + , FlatBag, sizeFlatBag, fromSizedSeq, elemsFlatBag ) where import GHC.Prelude import GHC.Data.FastString -import GHC.Data.SizedSeq +import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable @@ -33,10 +37,10 @@ import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq +import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray ) import Foreign import Data.Array -import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -152,10 +156,10 @@ = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap - unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs } instance NFData UnlinkedBCO where @@ -210,8 +214,8 @@ instance Outputable UnlinkedBCO where ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] + ppr (sizeFlatBag lits), text "lits", + ppr (sizeFlatBag ptrs), text "ptrs" ] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> diff --git a/GHC/Cmm/Dominators.hs b/GHC/Cmm/Dominators.hs --- a/GHC/Cmm/Dominators.hs +++ b/GHC/Cmm/Dominators.hs @@ -23,7 +23,6 @@ import GHC.Prelude import Data.Array.IArray -import Data.Foldable() import qualified Data.Tree as Tree import Data.Word diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -680,7 +680,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 134 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 134 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs --- a/GHC/Cmm/Opt.hs +++ b/GHC/Cmm/Opt.hs @@ -213,23 +213,33 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can +-- Make a RegOff if we can. We don't perform this optimization if rep is greater +-- than the host word size because we use an Int to store the offset. See +-- #24893 and #24700. This should be fixed to ensure that optimizations don't +-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -409,6 +419,13 @@ -- Anything else is just too hard. cmmMachOpFoldM _ _ _ = Nothing + +-- | Check that a literal width is compatible with the host word size used to +-- store offsets. This should be fixed properly (using larger types to store +-- literal offsets). See #24893 +validOffsetRep :: Width -> Bool +validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) + {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Cmm/ThreadSanitizer.hs b/GHC/Cmm/ThreadSanitizer.hs --- a/GHC/Cmm/ThreadSanitizer.hs +++ b/GHC/Cmm/ThreadSanitizer.hs @@ -184,7 +184,7 @@ restore = blockFromList restore_nodes -- | Mirrors __tsan_memory_order --- +-- memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr memoryOrderToTsanMemoryOrder env mord = mkIntExpr (platform env) n @@ -294,4 +294,3 @@ AMO_Or -> "fetch_or" AMO_Xor -> "fetch_xor" fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op' - diff --git a/GHC/CmmToAsm/AArch64.hs b/GHC/CmmToAsm/AArch64.hs --- a/GHC/CmmToAsm/AArch64.hs +++ b/GHC/CmmToAsm/AArch64.hs @@ -47,6 +47,7 @@ patchRegsOfInstr = AArch64.patchRegsOfInstr isJumpishInstr = AArch64.isJumpishInstr jumpDestsOfInstr = AArch64.jumpDestsOfInstr + canFallthroughTo = AArch64.canFallthroughTo patchJumpInstr = AArch64.patchJumpInstr mkSpillInstr = AArch64.mkSpillInstr mkLoadInstr = AArch64.mkLoadInstr diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1556,7 +1556,7 @@ -- pprTraceM "genCCall target" (ppr target) -- pprTraceM "genCCall formal" (ppr dest_regs) -- pprTraceM "genCCall actual" (ppr arg_regs) - + platform <- getPlatform case target of -- The target :: ForeignTarget call can either -- be a foreign procedure with an address expr @@ -1584,7 +1584,6 @@ let (_res_hints, arg_hints) = foreignTargetHints target arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints - platform <- getPlatform let packStack = platformOS platform == OSDarwin (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL @@ -1595,7 +1594,7 @@ then 8 * (stackSpace' `div` 8 + 1) else stackSpace' - (returnRegs, readResultsCode) <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL let moveStackDown 0 = toOL [ PUSH_STACK_FRAME , DELTA (-16) ] @@ -1613,7 +1612,7 @@ let code = call_target_code -- compute the label (possibly into a register) `appOL` moveStackDown (stackSpace `div` 8) `appOL` passArgumentsCode -- put the arguments into x0, ... - `appOL` (unitOL $ BL call_target passRegs returnRegs) -- branch and link. + `appOL` (unitOL $ BL call_target passRegs) -- branch and link. `appOL` readResultsCode -- parse the results into registers `appOL` moveStackUp (stackSpace `div` 8) return (code, Nothing) @@ -1621,10 +1620,303 @@ PrimTarget MO_F32_Fabs | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Fabs" PrimTarget MO_F64_Fabs | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Fabs" + PrimTarget MO_F32_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Sqrt" + PrimTarget MO_F64_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Sqrt" + + PrimTarget (MO_S_Mul2 w) + -- Life is easier when we're working with word sized operands, + -- we can use SMULH to compute the high 64 bits, and dst_needed + -- checks if the high half's bits are all the same as the low half's + -- top bit. + | w == W64 + , [src_a, src_b] <- arg_regs + -- dst_needed = did the result fit into just the low half + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + return ( + code_x `appOL` + code_y `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + -- Are all high bits equal to the sign bit of the low word? + -- nd = (hi == ASR(lo,width-1)) ? 1 : 0 + CMP (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL` + CSET (OpReg W64 nd) NE + , Nothing) + -- For sizes < platform width, we can just perform a multiply and shift + -- using the normal 64 bit multiply. Calculating the dst_needed value is + -- complicated a little by the need to be careful when truncation happens. + -- Currently this case can't be generated since + -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #) + -- TODO: Should this be removed or would other primops be useful? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a', _format_x, code_a) <- getSomeReg src_a + (reg_b', _format_y, code_b) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + -- Do everything in a full 64 bit registers + w' = platformWordWidth platform + + (reg_a, code_a') <- signExtendReg w w' reg_a' + (reg_b, code_b') <- signExtendReg w w' reg_b' + + return ( + code_a `appOL` + code_b `appOL` + code_a' `appOL` + code_b' `snocOL` + -- the low 2w' of lo contains the full multiplication; + -- eg: int8 * int8 -> int16 result + -- so lo is in the last w of the register, and hi is in the second w. + SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Make sure we hold onto the sign bits for dst_needed + ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` + -- lo can now be truncated so we can get at it's top bit easily. + truncateReg w' w lo `snocOL` + -- Note the use of CMN (compare negative), not CMP: we want to + -- test if the top half is negative one and the top + -- bit of the bottom half is positive one. eg: + -- hi = 0b1111_1111 (actually 64 bits) + -- lo = 0b1010_1111 (-81, so the result didn't need the top half) + -- lo' = ASR(lo,7) (second reg of SMN) + -- = 0b0000_0001 (theeshift gives us 1 for negative, + -- and 0 for positive) + -- hi == -lo'? + -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow) + -- Another way to think of this is if hi + lo' == 0, which is what + -- CMN really is under the hood. + CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` + -- Set dst_needed to 1 if hi and lo' were (negatively) equal + CSET (OpReg w' nd) EQ `appOL` + -- Finally truncate hi to drop any extraneous sign bits. + truncateReg w' w hi + , Nothing) + -- Can't handle > 64 bit operands + | otherwise -> unsupported (MO_S_Mul2 w) + PrimTarget (MO_U_Mul2 w) + -- The unsigned case is much simpler than the signed, all we need to + -- do is the multiplication straight into the destination registers. + | w == W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + return ( + code_x `appOL` + code_y `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) + , Nothing) + -- For sizes < platform width, we can just perform a multiply and shift + -- Need to be careful to truncate the low half, but the upper half should be + -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained. + -- Currently this case can't be produced by the compiler since + -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #) + -- TODO: Remove? Or would the extra primop be useful for avoiding the extra + -- steps needed to do this in userland? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + w' = opRegWidth w + return ( + code_x `appOL` + code_y `snocOL` + -- UMULL: Xd = Wa * Wb with 64 bit result + -- W64 inputs should have been caught by case above + UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Extract and truncate high result + -- hi[w:0] = lo[2w:w] + UBFX (OpReg W64 hi) (OpReg W64 lo) + (OpImm (ImmInt $ widthInBits w)) -- lsb + (OpImm (ImmInt $ widthInBits w)) -- width to extract + `appOL` + truncateReg W64 w lo + , Nothing) + | otherwise -> unsupported (MO_U_Mul2 w) + PrimTarget (MO_Clz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return ( + code_x `snocOL` + CLZ (OpReg w dst_reg) (OpReg w reg_a) + , Nothing) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 16 | 0x0000_8000) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + , Nothing) + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 24 | 0x0080_0000) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 24) + , ORR (r dst') (r dst') (imm 0x00800000) + , CLZ (r dst') (r dst') + ] + , Nothing) + | otherwise -> unsupported (MO_Clz w) + PrimTarget (MO_Ctz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return ( + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL` + CLZ (OpReg w dst_reg) (OpReg w dst_reg) + , Nothing) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0000_8000) -} + return ( + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + , Nothing) + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0080_0000) -} + return ( + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00800000) + , CLZ (r dst') (r dst') + ] + , Nothing) + | otherwise -> unsupported (MO_Ctz w) + PrimTarget (MO_BRev w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return ( + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) + , Nothing) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 16) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , RBIT (r dst') (r dst') + ] + , Nothing) + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 24) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 24) + , RBIT (r dst') (r dst') + ] + , Nothing) + | otherwise -> unsupported (MO_BRev w) + PrimTarget (MO_BSwap w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ (code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a), Nothing) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + -- Swaps the bytes in each 16bit word + -- TODO: Expose the 32 & 64 bit version of this? + return $ (code_x `snocOL` REV16 (r dst') (r reg_a), Nothing) + | otherwise -> unsupported (MO_BSwap w) + -- or a possibly side-effecting machine operation -- mop :: CallishMachOp (see GHC.Cmm.MachOp) PrimTarget mop -> do @@ -1653,8 +1945,6 @@ MO_F64_Log1P -> mkCCall "log1p" MO_F64_Exp -> mkCCall "exp" MO_F64_ExpM1 -> mkCCall "expm1" - MO_F64_Fabs -> mkCCall "fabs" - MO_F64_Sqrt -> mkCCall "sqrt" -- 32 bit float ops MO_F32_Pwr -> mkCCall "powf" @@ -1675,8 +1965,6 @@ MO_F32_Log1P -> mkCCall "log1pf" MO_F32_Exp -> mkCCall "expf" MO_F32_ExpM1 -> mkCCall "expm1f" - MO_F32_Fabs -> mkCCall "fabsf" - MO_F32_Sqrt -> mkCCall "sqrtf" -- 64-bit primops MO_I64_ToI -> mkCCall "hs_int64ToInt" @@ -1714,7 +2002,6 @@ -- Arithmatic -- These are not supported on X86, so I doubt they are used much. - MO_S_Mul2 _w -> unsupported mop MO_S_QuotRem _w -> unsupported mop MO_U_QuotRem _w -> unsupported mop MO_U_QuotRem2 _w -> unsupported mop @@ -1723,7 +2010,6 @@ MO_SubWordC _w -> unsupported mop MO_AddIntC _w -> unsupported mop MO_SubIntC _w -> unsupported mop - MO_U_Mul2 _w -> unsupported mop -- Memory Ordering MO_AcquireFence -> return (unitOL DMBISH, Nothing) @@ -1751,10 +2037,6 @@ MO_PopCnt w -> mkCCall (popCntLabel w) MO_Pdep w -> mkCCall (pdepLabel w) MO_Pext w -> mkCCall (pextLabel w) - MO_Clz w -> mkCCall (clzLabel w) - MO_Ctz w -> mkCCall (ctzLabel w) - MO_BSwap w -> mkCCall (bSwapLabel w) - MO_BRev w -> mkCCall (bRevLabel w) -- -- Atomic read-modify-write. MO_AtomicRead w ord @@ -1943,8 +2225,8 @@ passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") - readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock) - readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode) + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock) + readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do platform <- getPlatform pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -79,11 +79,14 @@ -- 1. Arithmetic Instructions ------------------------------------------------ ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) CMP l r -> usage (regOp l ++ regOp r, []) + CMN l r -> usage (regOp l ++ regOp r, []) MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) NEG dst src -> usage (regOp src, regOp dst) SMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) UDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) @@ -97,6 +100,11 @@ UXTB dst src -> usage (regOp src, regOp dst) SXTH dst src -> usage (regOp src, regOp dst) UXTH dst src -> usage (regOp src, regOp dst) + CLZ dst src -> usage (regOp src, regOp dst) + RBIT dst src -> usage (regOp src, regOp dst) + REV dst src -> usage (regOp src, regOp dst) + -- REV32 dst src -> usage (regOp src, regOp dst) + REV16 dst src -> usage (regOp src, regOp dst) -- 3. Logical and Move Instructions ------------------------------------------ AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) @@ -112,7 +120,7 @@ J t -> usage (regTarget t, []) B t -> usage (regTarget t, []) BCOND _ t -> usage (regTarget t, []) - BL t ps _rs -> usage (regTarget t ++ ps, callerSavedRegisters) + BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) -- 5. Atomic Instructions ---------------------------------------------------- -- 6. Conditional Instructions ----------------------------------------------- @@ -133,10 +141,12 @@ SCVTF dst src -> usage (regOp src, regOp dst) FCVTZS dst src -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst) + FSQRT dst src -> usage (regOp src, regOp dst) FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) - _ -> panic $ "regUsageOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "regUsageOfInstr: " ++ instrCon instr + NEWBLOCK{} -> panic $ "regUsageOfInstr: " ++ instrCon instr where -- filtering the usage is necessary, otherwise the register @@ -167,6 +177,8 @@ interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +-- Note [AArch64 Register assignments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 -- @@ -189,6 +201,8 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim +-- +-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters = map regSingle [0..18] @@ -209,11 +223,14 @@ -- 1. Arithmetic Instructions ---------------------------------------------- ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) CMP o1 o2 -> CMP (patchOp o1) (patchOp o2) + CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2) (patchOp o3) SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2) (patchOp o3) + UMULH o1 o2 o3 -> UMULH (patchOp o1) (patchOp o2) (patchOp o3) + UMULL o1 o2 o3 -> UMULL (patchOp o1) (patchOp o2) (patchOp o3) SDIV o1 o2 o3 -> SDIV (patchOp o1) (patchOp o2) (patchOp o3) SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) UDIV o1 o2 o3 -> UDIV (patchOp o1) (patchOp o2) (patchOp o3) @@ -227,7 +244,13 @@ UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2) SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2) UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2) + CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2) + RBIT o1 o2 -> RBIT (patchOp o1) (patchOp o2) + REV o1 o2 -> REV (patchOp o1) (patchOp o2) + -- REV32 o1 o2 -> REV32 (patchOp o1) (patchOp o2) + REV16 o1 o2 -> REV16 (patchOp o1) (patchOp o2) + -- 3. Logical and Move Instructions ---------------------------------------- AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3) @@ -243,7 +266,7 @@ -- 4. Branch Instructions -------------------------------------------------- J t -> J (patchTarget t) B t -> B (patchTarget t) - BL t rs ts -> BL (patchTarget t) rs ts + BL t rs -> BL (patchTarget t) rs BCOND c t -> BCOND c (patchTarget t) -- 5. Atomic Instructions -------------------------------------------------- @@ -265,10 +288,12 @@ SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2) FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) - _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + NEWBLOCK{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r) @@ -307,10 +332,16 @@ jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] -jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]] +jumpDestsOfInstr (BL t _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = [] +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid +canFallthroughTo (J (TBlock target)) bid = bid == target +canFallthroughTo (B (TBlock target)) bid = bid == target +canFallthroughTo _ _ = False + -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join -- points. @@ -322,7 +353,7 @@ CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid)) J (TBlock bid) -> J (TBlock (patchF bid)) B (TBlock bid) -> B (TBlock (patchF bid)) - BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs + BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) _ -> panic $ "patchJumpInstr: " ++ instrCon instr @@ -540,6 +571,7 @@ -- | ADR ... -- | ADRP ... | CMP Operand Operand -- rd - op2 + | CMN Operand Operand -- rd + op2 -- | MADD ... -- | MNEG ... | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm @@ -562,8 +594,8 @@ -- | UMADDL ... -- Xd = Xa + Wn × Wm -- | UMNEGL ... -- Xd = - Wn × Wm -- | UMSUBL ... -- Xd = Xa - Wn × Wm - -- | UMULH ... -- Xd = (Xn × Xm)_127:64 - -- | UMULL ... -- Xd = Wn × Wm + | UMULH Operand Operand Operand -- Xd = (Xn × Xm)_127:64 + | UMULL Operand Operand Operand -- Xd = Wn × Wm -- 2. Bit Manipulation Instructions ---------------------------------------- | SBFM Operand Operand Operand Operand -- rd = rn[i,j] @@ -576,6 +608,14 @@ -- Signed/Unsigned bitfield extract | SBFX Operand Operand Operand Operand -- rd = rn[i,j] | UBFX Operand Operand Operand Operand -- rd = rn[i,j] + | CLZ Operand Operand -- rd = countLeadingZeros(rn) + | RBIT Operand Operand -- rd = reverseBits(rn) + | REV Operand Operand -- rd = reverseBytes(rn): (for 32 & 64 bit operands) + -- 0xAABBCCDD -> 0xDDCCBBAA + | REV16 Operand Operand -- rd = reverseBytes16(rn) + -- 0xAABB_CCDD -> xBBAA_DDCC + -- | REV32 Operand Operand -- rd = reverseBytes32(rn) - 64bit operands only! + -- -- 0xAABBCCDD_EEFFGGHH -> 0XDDCCBBAA_HHGGFFEE -- 3. Logical and Move Instructions ---------------------------------------- | AND Operand Operand Operand -- rd = rn & op2 @@ -604,7 +644,7 @@ -- Branching. | J Target -- like B, but only generated from genJump. Used to distinguish genJumps from others. | B Target -- unconditional branching b/br. (To a blockid, label or register) - | BL Target [Reg] [Reg] -- branch and link (e.g. set x30 to next pc, and branch) + | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch) | BCOND Cond Target -- branch with condition. b. -- 8. Synchronization Instructions ----------------------------------------- @@ -618,6 +658,8 @@ | FCVTZS Operand Operand -- Float ABSolute value | FABS Operand Operand + -- Float SQuare RooT + | FSQRT Operand Operand -- | Floating-point fused multiply-add instructions -- @@ -644,18 +686,26 @@ POP_STACK_FRAME{} -> "POP_STACK_FRAME" ADD{} -> "ADD" CMP{} -> "CMP" + CMN{} -> "CMN" MSUB{} -> "MSUB" MUL{} -> "MUL" NEG{} -> "NEG" SDIV{} -> "SDIV" SMULH{} -> "SMULH" SMULL{} -> "SMULL" + UMULH{} -> "UMULH" + UMULL{} -> "UMULL" SUB{} -> "SUB" UDIV{} -> "UDIV" SBFM{} -> "SBFM" UBFM{} -> "UBFM" SBFX{} -> "SBFX" UBFX{} -> "UBFX" + CLZ{} -> "CLZ" + RBIT{} -> "RBIT" + REV{} -> "REV" + REV16{} -> "REV16" + -- REV32{} -> "REV32" AND{} -> "AND" ASR{} -> "ASR" EOR{} -> "EOR" @@ -682,6 +732,7 @@ SCVTF{} -> "SCVTF" FCVTZS{} -> "FCVTZS" FABS{} -> "FABS" + FSQRT{} -> "FSQRT" FMA variant _ _ _ _ -> case variant of FMAdd -> "FMADD" diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs --- a/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/GHC/CmmToAsm/AArch64/Ppr.hs @@ -316,6 +316,7 @@ | w == W64 = text "sp" | w == W32 = text "wsp" + -- See Note [AArch64 Register assignments] ppr_reg_no w i | i < 0, w == W32 = text "wzr" | i < 0, w == W64 = text "xzr" @@ -372,12 +373,15 @@ CMP o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2 | otherwise -> op2 (text "\tcmp") o1 o2 + CMN o1 o2 -> op2 (text "\tcmn") o1 o2 MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4 MUL o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3 | otherwise -> op3 (text "\tmul") o1 o2 o3 SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3 SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3 + UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3 + UMULL o1 o2 o3 -> op3 (text "\tumull") o1 o2 o3 NEG o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2 | otherwise -> op2 (text "\tneg") o1 o2 @@ -393,6 +397,11 @@ -- 2. Bit Manipulation Instructions ------------------------------------------ SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4 UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4 + CLZ o1 o2 -> op2 (text "\tclz") o1 o2 + RBIT o1 o2 -> op2 (text "\trbit") o1 o2 + REV o1 o2 -> op2 (text "\trev") o1 o2 + REV16 o1 o2 -> op2 (text "\trev16") o1 o2 + -- REV32 o1 o2 -> op2 (text "\trev32") o1 o2 -- signed and unsigned bitfield extract SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4 UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4 @@ -421,9 +430,9 @@ B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r - BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl - BL (TReg r) _ _ -> line $ text "\tblr" <+> pprReg W64 r + BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ -> line $ text "\tblr" <+> pprReg W64 r BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl @@ -525,6 +534,7 @@ SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2 FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2 FABS o1 o2 -> op2 (text "\tfabs") o1 o2 + FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2 FMA variant d r1 r2 r3 -> let fma = case variant of FMAdd -> text "\tfmadd" diff --git a/GHC/CmmToAsm/AArch64/Regs.hs b/GHC/CmmToAsm/AArch64/Regs.hs --- a/GHC/CmmToAsm/AArch64/Regs.hs +++ b/GHC/CmmToAsm/AArch64/Regs.hs @@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs --- a/GHC/CmmToAsm/BlockLayout.hs +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -771,10 +771,9 @@ dropJumps _ [] = [] dropJumps info (BasicBlock lbl ins:todo) | Just ins <- nonEmpty ins --This can happen because of shortcutting - , [dest] <- jumpDestsOfInstr (NE.last ins) , BasicBlock nextLbl _ : _ <- todo - , not (mapMember dest info) - , nextLbl == dest + , canFallthroughTo (NE.last ins) nextLbl + , not (mapMember nextLbl info) = BasicBlock lbl (NE.init ins) : dropJumps info todo | otherwise = BasicBlock lbl ins : dropJumps info todo diff --git a/GHC/CmmToAsm/Instr.hs b/GHC/CmmToAsm/Instr.hs --- a/GHC/CmmToAsm/Instr.hs +++ b/GHC/CmmToAsm/Instr.hs @@ -71,10 +71,16 @@ :: instr -> Bool - -- | Give the possible destinations of this jump instruction. + -- | Give the possible *local block* destinations of this jump instruction. -- Must be defined for all jumpish instructions. jumpDestsOfInstr :: instr -> [BlockId] + + -- | Check if the instr always transfers control flow + -- to the given block. Used by code layout to eliminate + -- jumps that can be replaced by fall through. + canFallthroughTo + :: instr -> BlockId -> Bool -- | Change the destination of this jump instruction. diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs --- a/GHC/CmmToAsm/Monad.hs +++ b/GHC/CmmToAsm/Monad.hs @@ -78,8 +78,15 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, + -- | Does this jump always jump to a single destination and is shortcutable? + -- + -- We use this to determine shortcutable instructions - See Note [What is shortcutting] + -- Note that if we return a destination here we *most* support the relevant shortcutting in + -- shortcutStatics for jump tables and shortcutJump for the instructions itself. canShortcut :: instr -> Maybe jumpDest, + -- | Replace references to blockIds with other destinations - used to update jump tables. shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + -- | Change the jump destination(s) of an instruction. shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel. @@ -104,6 +111,25 @@ -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \@ -- when possible. } + +{- Note [supporting shortcutting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the concept of shortcutting see Note [What is shortcutting]. + +In order to support shortcutting across multiple backends uniformly we +use canShortcut, shortcutStatics and shortcutJump. + +canShortcut tells us if the backend support shortcutting of a instruction +and if so what destination we should retarget instruction to instead. + +shortcutStatics exists to allow us to update jump destinations in jump tables. + +shortcutJump updates the instructions itself. + +A backend can opt out of those by always returning Nothing for canShortcut +and implementing shortcutStatics/shortcutJump as \_ x -> x + +-} {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/CmmToAsm/PPC.hs b/GHC/CmmToAsm/PPC.hs --- a/GHC/CmmToAsm/PPC.hs +++ b/GHC/CmmToAsm/PPC.hs @@ -46,6 +46,7 @@ patchRegsOfInstr = PPC.patchRegsOfInstr isJumpishInstr = PPC.isJumpishInstr jumpDestsOfInstr = PPC.jumpDestsOfInstr + canFallthroughTo = PPC.canFallthroughTo patchJumpInstr = PPC.patchJumpInstr mkSpillInstr = PPC.mkSpillInstr mkLoadInstr = PPC.mkLoadInstr diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs --- a/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -1770,7 +1770,7 @@ _ -> panic "genCall': unknown calling conv." argReps = map (cmmExprType platform) args - (argHints, _) = foreignTargetHints target + (_, argHints) = foreignTargetHints target roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) diff --git a/GHC/CmmToAsm/PPC/Instr.hs b/GHC/CmmToAsm/PPC/Instr.hs --- a/GHC/CmmToAsm/PPC/Instr.hs +++ b/GHC/CmmToAsm/PPC/Instr.hs @@ -22,6 +22,7 @@ , patchJumpInstr , patchRegsOfInstr , jumpDestsOfInstr + , canFallthroughTo , takeRegRegMoveInstr , takeDeltaInstr , mkRegRegMoveInstr @@ -508,6 +509,13 @@ BL{} -> True JMP{} -> True _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo instr bid + = case instr of + BCC _ target _ -> target == bid + BCCFAR _ target _ -> target == bid + _ -> False -- | Checks whether this instruction is a jump/branch instruction. diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -183,7 +183,8 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> 28 -- 32 - D1..D4 + ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use. + -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/GHC/CmmToAsm/Reg/Liveness.hs b/GHC/CmmToAsm/Reg/Liveness.hs --- a/GHC/CmmToAsm/Reg/Liveness.hs +++ b/GHC/CmmToAsm/Reg/Liveness.hs @@ -126,6 +126,11 @@ Instr instr -> isJumpishInstr instr _ -> False + canFallthroughTo i bid + = case i of + Instr instr -> canFallthroughTo instr bid + _ -> False + jumpDestsOfInstr i = case i of Instr instr -> jumpDestsOfInstr instr diff --git a/GHC/CmmToAsm/X86.hs b/GHC/CmmToAsm/X86.hs --- a/GHC/CmmToAsm/X86.hs +++ b/GHC/CmmToAsm/X86.hs @@ -51,6 +51,7 @@ patchRegsOfInstr = X86.patchRegsOfInstr isJumpishInstr = X86.isJumpishInstr jumpDestsOfInstr = X86.jumpDestsOfInstr + canFallthroughTo = X86.canFallthroughTo patchJumpInstr = X86.patchJumpInstr mkSpillInstr = X86.mkSpillInstr mkLoadInstr = X86.mkLoadInstr diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -2660,10 +2660,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall32 addr conv dest_regs args = do +genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do config <- getConfig let platform = ncgPlatform config - prom_args = map (maybePromoteCArg platform W32) args + args_hints = zip args (argHints ++ repeat NoHint) + prom_args = map (maybePromoteCArg platform W32) args_hints -- If the size is smaller than the word, we widen things (see maybePromoteCArg) arg_size_bytes :: CmmType -> Int @@ -2817,10 +2818,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall64 addr conv dest_regs args = do +genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do platform <- getPlatform -- load up the register arguments - let prom_args = map (maybePromoteCArg platform W32) args + let args_hints = zip args (argHints ++ repeat NoHint) + let prom_args = map (maybePromoteCArg platform W32) args_hints let load_args :: [CmmExpr] -> [Reg] -- int regs avail for args @@ -3058,9 +3060,11 @@ assign_code dest_regs) -maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr -maybePromoteCArg platform wto arg - | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] +maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr +maybePromoteCArg platform wto (arg, hint) + | wfrom < wto = case hint of + SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] + _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] | otherwise = arg where wfrom = cmmExprWidth platform arg diff --git a/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs --- a/GHC/CmmToAsm/X86/Instr.hs +++ b/GHC/CmmToAsm/X86/Instr.hs @@ -31,6 +31,7 @@ , mkSpillInstr , mkRegRegMoveInstr , jumpDestsOfInstr + , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr @@ -669,6 +670,17 @@ CALL{} -> True _ -> False +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid + = case insn of + JXX _ target -> bid == target + JMP_TBL _ targets _ _ -> all isTargetBid targets + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just (DestBlockId target) -> target == bid + _ -> False jumpDestsOfInstr :: Instr diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs --- a/GHC/CmmToLlvm.hs +++ b/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head ) +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -38,8 +38,7 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) -import Data.List.NonEmpty ( head ) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe ( fromMaybe, catMaybes, isNothing ) import System.IO -- ----------------------------------------------------------------------------- @@ -69,11 +68,13 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." - let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X - let major_ver = head . llvmVersionNE $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ - "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> - "You are using LLVM version: " <> text (llvmVersionStr ver) + + when (isNothing mb_ver) $ do + let doWarn = llvmCgDoWarn cfg + when doWarn $ putMsg logger $ + "Failed to detect LLVM version!" $$ + "Make sure LLVM is installed correctly." $$ + "We will try though..." -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation diff --git a/GHC/Core/LateCC.hs b/GHC/Core/LateCC.hs --- a/GHC/Core/LateCC.hs +++ b/GHC/Core/LateCC.hs @@ -21,6 +21,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable +import GHC.Types.RepType (mightBeFunTy) -- | Late cost center insertion logic used by the driver addLateCostCenters :: @@ -78,8 +79,11 @@ top_level_cc_pred :: CoreExpr -> Bool top_level_cc_pred = case lateCCConfig_whichBinds of - LateCCAllBinds -> - const True + LateCCBinds -> \rhs -> + -- Make sure we record any functions. Even if it's something like `f = g`. + mightBeFunTy (exprType rhs) || + -- If the RHS is a CAF doing work also insert a CC. + not (exprIsWorkFree rhs) LateCCOverloadedBinds -> isOverloadedTy . exprType LateCCNone -> diff --git a/GHC/Core/LateCC/TopLevelBinds.hs b/GHC/Core/LateCC/TopLevelBinds.hs --- a/GHC/Core/LateCC/TopLevelBinds.hs +++ b/GHC/Core/LateCC/TopLevelBinds.hs @@ -3,16 +3,18 @@ import GHC.Prelude -import GHC.Core --- import GHC.Core.LateCC import GHC.Core.LateCC.Types import GHC.Core.LateCC.Utils + +import GHC.Core import GHC.Core.Opt.Monad import GHC.Driver.DynFlags import GHC.Types.Id import GHC.Types.Name import GHC.Unit.Module.ModGuts +import Data.Maybe + {- Note [Collecting late cost centres] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Usually cost centres defined by a module are collected @@ -26,7 +28,7 @@ Note [Adding late cost centres to top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is very simple. For every top level binder +The basic idea is very simple. For a top level binder `f = rhs` we compile it as if the user had written `f = {-# SCC f #-} rhs`. @@ -37,6 +39,21 @@ we provide flags for both approaches as they have different tradeoffs. +To reduce overhead we ignore workfree bindings because they don't contribute +meaningfully to a performance profile. This reduces code size massively as it +allows us to allocate definitions like `val = Just 32` at compile time instead +of turning them into a CAF of the form `val = let x = Just 32 in x` which +would be the alternative. + +We make an exception for rhss with function types. This allows us to get +cost centres on eta-reduced definitions like `f = g`. By putting a tick onto +`f`s rhs we end up with + + f = \eta1 eta2 ... etan -> + g eta1 ... etan + +Which can make it easier to understand call graphs of an application. + We also don't add a cost centre for any binder that is a constructor worker or wrapper. These will never meaningfully enrich the resulting profile so we improve efficiency by omitting those. @@ -89,15 +106,20 @@ doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr doBndr bndr rhs - -- Cost centres on constructor workers are pretty much useless - -- so we don't emit them if we are looking at the rhs of a constructor - -- binding. - | Just _ <- isDataConId_maybe bndr = pure rhs - | otherwise = if pred rhs then addCC bndr rhs else pure rhs + -- Not a constructor worker. + -- Cost centres on constructor workers are pretty much useless so we don't emit them + -- if we are looking at the rhs of a constructor binding. + | isNothing (isDataConId_maybe bndr) + , pred rhs + = addCC bndr rhs + | otherwise = pure rhs -- We want to put the cost centre below the lambda as we only care about - -- executions of the RHS. + -- executions of the RHS. Note that the lambdas might be hidden under ticks + -- or casts. So look through these as well. addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co + addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs addCC bndr rhs = do let name = idName bndr diff --git a/GHC/Core/LateCC/Types.hs b/GHC/Core/LateCC/Types.hs --- a/GHC/Core/LateCC/Types.hs +++ b/GHC/Core/LateCC/Types.hs @@ -34,7 +34,7 @@ -- | The types of top-level bindings we support adding cost centers to. data LateCCBindSpec = LateCCNone - | LateCCAllBinds + | LateCCBinds | LateCCOverloadedBinds -- | Late cost centre insertion environment diff --git a/GHC/Core/Map/Type.hs b/GHC/Core/Map/Type.hs --- a/GHC/Core/Map/Type.hs +++ b/GHC/Core/Map/Type.hs @@ -228,7 +228,7 @@ andEq TEQX e = hasCast e andEq TEQ e = e - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type + -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 [])) | tc1 == tc2 = TEQ diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -860,7 +860,7 @@ -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work -exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType +exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y -- Nothing if the expression has arity 0 @@ -2359,8 +2359,8 @@ (mkNomReflCo (varType tcv)) co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has - -- a ForAllTyFlag of coreTyLamForAllTyFlag; see wrinkle (FC4) in - -- Note [ForAllCo] in GHC.Core.TyCo.Rep + -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep {- ************************************************************************ diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs --- a/GHC/Core/Opt/ConstantFold.hs +++ b/GHC/Core/Opt/ConstantFold.hs @@ -2660,6 +2660,10 @@ inline f_ty (f a b c) = a b c (if f has an unfolding, EVEN if it's a loop breaker) + Additionally the rule looks through ticks/casts as well (#24808): + inline f_ty (f a b c |> co) = a b c |> co + inline f_ty ( f a b c ) = a b c + It's important to allow the argument to 'inline' to have args itself (a) because its more forgiving to allow the programmer to write either inline f a b c @@ -2672,11 +2676,17 @@ -} match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) +match_inline (Type _ : e : _) = go e + -- Maybe Monad ahead: + where + go (Var f) = -- Ignore the IdUnfoldingFun here! + (maybeUnfoldingTemplate (realIdUnfolding f)) + go (App f a) = do { f' <- go f; pure $ App f' a } + -- inline (f |> co) + go (Cast e co) = do { app <- go e; pure (Cast app co) } + -- inline ( f) + go (Tick t e) = do { app <- go e; pure (Tick t app) } + go _ = Nothing match_inline _ = Nothing diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs --- a/GHC/Core/Opt/DmdAnal.hs +++ b/GHC/Core/Opt/DmdAnal.hs @@ -1028,10 +1028,10 @@ TopLevel | isInterestingTopLevelFn var -- Top-level things will be used multiple times or not at - -- all anyway, hence the multDmd below: It means we don't + -- all anyway, hence the `floatifyDmd`: it means we don't -- have to track whether @var@ is used strictly or at most - -- once, because ultimately it never will. - -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness + -- once, because ultimately it never will + -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd)) | otherwise -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later -- Everything else: diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -1035,8 +1035,6 @@ | otherwise = (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs ) where - is_join_point = isJoinPoint mb_join - --------- Right hand side --------- -- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have -- join j = Just (f x) in ... @@ -1044,12 +1042,9 @@ -- let y = f x in join j = Just y in ... -- That's that OccRhs would do; but there's no point because -- j will never be scrutinised. - env1 | is_join_point = setTailCtxt env - | otherwise = setNonTailCtxt rhs_ctxt env -- Zap occ_join_points + rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs rhs_ctxt = mkNonRecRhsCtxt bndr unf - -- See Note [Sources of one-shot information] - rhs_env = addOneShotsFromDmd bndr env1 -- See Note [Join arity prediction based on joinRhsArity] -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; @@ -1059,16 +1054,15 @@ final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] | otherwise = bndr `setIdSpecialisation` mkRuleInfo rules' - `setIdUnfolding` unf2 + `setIdUnfolding` unf1 final_bndr_no_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] - | otherwise = bndr `setIdUnfolding` unf2 + | otherwise = bndr `setIdUnfolding` unf1 --------- Unfolding --------- -- See Note [Join points and unfoldings/rules] unf = idUnfolding bndr WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf - unf2 = markNonRecUnfoldingOneShots mb_join unf1 adj_unf_uds = adjustTailArity mb_join unf_tuds --------- Rules --------- @@ -1142,10 +1136,8 @@ | isDeadOcc occ -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise - = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr + = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds - !unf' = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr) - !bndr' = tagged_bndr `setIdUnfolding` unf' in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -1750,10 +1742,9 @@ -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage -- until occAnalRec. In effect, we pretend that the RHS becomes a -- non-recursive join point and fix up later with adjustTailUsage. - rhs_env | isJoinId bndr = setTailCtxt env - | otherwise = setNonTailCtxt OccRhs env - -- If bndr isn't an /existing/ join point, it's safe to zap the - -- occ_join_points, because they can't occur in RHS. + rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs + -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint), + -- it's safe to zap the occ_join_points, because they can't occur in RHS. WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders @@ -2167,7 +2158,7 @@ in WTUD (TUD (joinRhsArity expr) usage) expr' occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr --- Does not markInsidLam etc for the outmost batch of lambdas +-- Does not markInsideLam etc for the outmost batch of lambdas occ_anal_lam_tail env expr@(Lam {}) = go env [] expr where @@ -2308,20 +2299,8 @@ occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails) -{- Note [Join point RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = e - join j = Just x - -We want to inline x into j right away, so we don't want to give -the join point a RhsCtxt (#14137). It's not a huge deal, because -the FloatIn pass knows to float into join point RHSs; and the simplifier -does not float things out of join point RHSs. But it's a simple, cheap -thing to do. See #14137. - -Note [Occurrences in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Occurrences in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f p = BIG {-# INLINE g #-} @@ -2357,17 +2336,33 @@ empty. This just saves a bit of allocation and reconstruction; not a big deal. -This fast path exposes a tricky cornder, though (#22761). Supose we have +Two tricky corners: + +* Dead bindings (#22761). Supose we have Unfolding = \x. let y = foo in x+1 -which includes a dead binding for `y`. In occAnalUnfolding we occ-anal -the unfolding and produce /no/ occurrences of `foo` (since `y` is -dead). But if we discard the occ-analysed syntax tree (which we do on -our fast path), and use the old one, we still /have/ an occurrence of -`foo` -- and that can lead to out-of-scope variables (#22761). + which includes a dead binding for `y`. In occAnalUnfolding we occ-anal + the unfolding and produce /no/ occurrences of `foo` (since `y` is + dead). But if we discard the occ-analysed syntax tree (which we do on + our fast path), and use the old one, we still /have/ an occurrence of + `foo` -- and that can lead to out-of-scope variables (#22761). -Solution: always keep occ-analysed trees in unfoldings and rules, so they -have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. + Solution: always keep occ-analysed trees in unfoldings and rules, so they + have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. +* One-shot binders. Consider + {- f has Stable unfolding \p q -> blah + Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -} + f = \x y. blah + + Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has + occ_one_shots = [NoOneShortInfo, OneShotLam] + This will put OneShotLam on the \y. And it'll put it on the \q. But the + noBinderSwap check will mean that we discard this new occ-anal'd unfolding + and keep the old one, with no OneShotInfo. + + This looks a little inconsistent, but the Stable unfolding is just used for + inlinings; OneShotInfo isn't a lot of use here. + Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an OccRhs for the RHS of a binding. This tells the @@ -2592,7 +2587,7 @@ | otherwise = case one_shots of [] -> (env_args, []) -- Fast path; one_shots is often empty - (os : one_shots') -> (addOneShots os env_args, one_shots') + (os : one_shots') -> (setOneShots os env_args, one_shots') {- Applications are dealt with specially because we want @@ -2888,42 +2883,125 @@ -- non-default alternative. That in turn influences -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! +{- Note [The OccEnv for a right hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we create the OccEnv for a RHS (in mkRhsOccEnv)? + +For a non-join point binding, x = rhs + + * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles + + * occ_join_points: zap them! + + * occ_one_shots: initialise from the idDemandInfo; + see Note [Sources of one-shot information] + +For a join point binding, j x = rhs + + * occ_encl: Consider + x = e + join j = Just x + We want to inline x into j right away, so we don't want to give the join point + a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the + FloatIn pass knows to float into join point RHSs; and the simplifier does not + float things out of join point RHSs. But it's a simple, cheap thing to do. + + * occ_join_points: no need to zap. + + * occ_one_shots: we start with one-shot-info from the context, which indeed + applies to the /body/ of the join point, after walking past the binders. + So we add to the front a OneShotInfo for each value-binder of the join + point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point + binders caused #25096.) + + For the join point binders themselves, of a /non-recursive/ join point, + we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`. + + These one-shot infos then get attached to the binder by `occAnalLamTail`. +-} + setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv setNonTailCtxt ctxt !env = env { occ_encl = ctxt , occ_one_shots = [] - , occ_join_points = zapped_jp_env } - where - -- zapped_jp_env is basically just emptyVarEnv (hence zapped). See (W3) of - -- Note [Occurrence analysis for join points] Zapping improves efficiency, - -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and - -- then find an occurrence of jx anyway, you might lose those uds, and - -- that might mean we don't record all occurrencs, and that means we - -- duplicate a redex.... a very nasty bug (which I encountered!). Hence - -- this DEBUG code which doesn't remove jx from the envt; it just gives it - -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch - -- this bug before it does any damage. -#ifdef DEBUG - zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env) -#else - zapped_jp_env = emptyVarEnv -#endif + , occ_join_points = zapJoinPointInfo (occ_join_points env) } setTailCtxt :: OccEnv -> OccEnv -setTailCtxt !env - = env { occ_encl = OccVanilla } +setTailCtxt !env = env { occ_encl = OccVanilla } -- Preserve occ_one_shots, occ_join points -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt): - -- see Note [Join point RHSs] -addOneShots :: OneShots -> OccEnv -> OccEnv -addOneShots os !env +mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv +-- See Note [The OccEnv for a right hand side] +-- For a join point: +-- - Keep occ_one_shots, occ_joinPoints from the context +-- - But push enough OneShotInfo onto occ_one_shots to account +-- for the join-point value binders +-- - Set occ_encl to OccVanilla +-- For non-join points +-- - Zap occ_one_shots and occ_join_points +-- - Set occ_encl to specified OccEncl +mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points }) + is_rec encl jp_hood bndr rhs + | JoinPoint join_arity <- jp_hood + = env { occ_encl = OccVanilla + , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + , occ_join_points = ctxt_join_points } + + | otherwise + = env { occ_encl = encl + , occ_one_shots = argOneShots (idDemandInfo bndr) + -- argOneShots: see Note [Sources of one-shot information] + , occ_join_points = zapJoinPointInfo ctxt_join_points } + +zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo +-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped). +-- See (W3) of Note [Occurrence analysis for join points] +-- +-- Zapping improves efficiency, slightly, if you accidentally introduce a bug, +-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you +-- might lose those uds, and that might mean we don't record all occurrencs, and +-- that means we duplicate a redex.... a very nasty bug (which I encountered!). +-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it +-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this +-- bug before it does any damage. +#ifdef DEBUG +zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info +#else +zapJoinPointInfo _ = emptyVarEnv +#endif + +extendOneShotsForJoinPoint + :: RecFlag -> JoinArity -> CoreExpr + -> [OneShotInfo] -> [OneShotInfo] +-- Push enough OneShortInfos on the front of ctxt_one_shots +-- to account for the value lambdas of the join point +extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + = go join_arity rhs + where + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + -- But not so for recursive ones + os = case is_rec of + NonRecursive -> OneShotLam + Recursive -> NoOneShotInfo + + go 0 _ = ctxt_one_shots + go n (Lam b rhs) + | isId b = os : go (n-1) rhs + | otherwise = go (n-1) rhs + go _ _ = [] -- Not enough lambdas. This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + +setOneShots :: OneShots -> OccEnv -> OccEnv +setOneShots os !env | null os = env -- Fast path for common case | otherwise = env { occ_one_shots = os } -addOneShotsFromDmd :: Id -> OccEnv -> OccEnv -addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr)) - isRhsEnv :: OccEnv -> Bool isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of OccRhs -> True @@ -3705,17 +3783,10 @@ -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the -- AcyclicSCC case of occAnalRec. --- * It applies 'markNonRecJoinOneShots' to the RHS --- * and returns the adjusted rhs UsageDetails combined with the body usage +-- It returns the adjusted rhs UsageDetails combined with the body usage adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs) - = WUD rhs_uds' rhs' - where - --------- Marking (non-rec) join binders one-shot --------- - !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs - | otherwise = rhs + = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs - --------- Adjusting right-hand side usage --------- - rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds adjustTailUsage :: JoinPointHood -> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail @@ -3732,33 +3803,6 @@ adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage - -markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr --- For a /non-recursive/ join point we can mark all --- its join-lambda as one-shot; and it's a good idea to do so -markNonRecJoinOneShots join_arity rhs - = go join_arity rhs - where - go 0 rhs = rhs - go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b) - (go (n-1) rhs) - go _ rhs = rhs -- Not enough lambdas. This can legitimately happen. - -- e.g. let j = case ... in j True - -- This will become an arity-1 join point after the - -- simplifier has eta-expanded it; but it may not have - -- enough lambdas /yet/. (Lint checks that JoinIds do - -- have enough lambdas.) - -markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding --- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding -markNonRecUnfoldingOneShots mb_join_arity unf - | JoinPoint ja <- mb_join_arity - , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf - , isStableSource src - , let !tmpl' = markNonRecJoinOneShots ja tmpl - = unf{uf_tmpl=tmpl'} - | otherwise - = unf type IdWithOccInfo = Id diff --git a/GHC/Core/Opt/SetLevels.hs b/GHC/Core/Opt/SetLevels.hs --- a/GHC/Core/Opt/SetLevels.hs +++ b/GHC/Core/Opt/SetLevels.hs @@ -991,6 +991,11 @@ as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot argument. + Do /not/ do this for bottoming /join-point/ bindings. They may call other + join points (#24768), and floating to the top would abstract over those join + points, which we should never do. + + See Maessen's paper 1999 "Bottom extraction: factoring error handling out of functional programs" (unpublished I think). @@ -1188,9 +1193,11 @@ deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs - is_bot_lam = isJust mb_bot_str + is_bot_lam = not is_join && isJust mb_bot_str -- is_bot_lam: looks like (\xy. bot), maybe zero lams - -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) + -- NB: not isBottomThunk! + -- NB: not is_join: don't send bottoming join points to the top. + -- See Note [Bottoming floats] point (3) n_extra = count isId abs_vars mb_join_arity = idJoinPointHood bndr @@ -1809,7 +1816,6 @@ env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) dest_lvl vs = do { let vs1 = map zap vs - -- See Note [Zapping the demand info] ; (subst', vs2) <- case is_rec of NonRecursive -> cloneBndrs subst vs1 Recursive -> cloneRecIdBndrs subst vs1 @@ -1822,9 +1828,12 @@ ; return (env', vs2) } where zap :: Var -> Var - zap v | isId v = zap_join (zapIdDemandInfo v) + -- See Note [Floatifying demand info when floating] + -- and Note [Zapping JoinId when floating] + zap v | isId v = zap_join (floatifyIdDemandInfo v) | otherwise = v + -- See Note [Zapping JoinId when floating] zap_join | isTopLvl dest_lvl = zapJoinId | otherwise = id @@ -1833,16 +1842,38 @@ | isTyVar v = delVarEnv id_env v | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1) -{- -Note [Zapping the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -VERY IMPORTANT: we must zap the demand info if the thing is going to -float out, because it may be less demanded than at its original -binding site. Eg - f :: Int -> Int - f x = let v = 3*4 in v+x -Here v is strict; but if we float v to top level, it isn't any more. +{- Note [Zapping JoinId when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we are floating a join point, it won't be one anymore, so we zap +the join point information. -Similarly, if we're floating a join point, it won't be one anymore, so we zap -join point information as well. +Note [Floatifying demand info when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating we must lazify the outer demand info on the Id +because it may be less demanded than at its original binding site. +For example: + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict and used at most once; but if we float v to top level, +that isn't true any more. Specifically, we lose track of v's cardinality info: + * if `f` is called multiple times, then `v` is used more than once + * if `f` is never called, then `v` is never evaluated. + +But NOTE that we only need to adjust the /top-level/ cardinality info. +For example + let x = (e1,e2) + in ...(case x of (a,b) -> a+b)... +If we float x outwards, it may no longer be strict, but IF it is ever +evaluated THEN its components will be evaluated. So we to lazify and +many-ify its demand-info, not discard it entirely. + +Same if we have + let f = \x y . blah + in ...(f a b)...(f c d)... +Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can +keep that `1C` called-once inner demand. It's only the outer strictness +that we kill. + +Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the +fact that `v` may be used any number of times, from zero upwards. -} diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs --- a/GHC/Core/Opt/Simplify/Iteration.hs +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -971,7 +971,7 @@ -- Demand info: Note [Setting the demand info] info3 | isEvaldUnfolding new_unf - = zapDemandInfo info2 `orElse` info2 + = lazifyDemandInfo info2 `orElse` info2 | otherwise = info2 @@ -2278,34 +2278,44 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey - , [ TyArg {}, TyArg {} ] <- rev_args - -- Do this even if (contIsStop cont) + , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args + -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] = do { let arg_env = arg_se `setInScopeFromE` env - ty' = contResultType cont + overall_res_ty = contResultType cont + -- hole_ty is the type of the current runRW# application + (outer_cont, new_runrw_res_ty, inner_cont) + | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont) + | otherwise = (cont, hole_ty, mkBoringStop hole_ty) + -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + -- If the argument is a literal lambda already, take a short cut - -- This isn't just efficiency; if we don't do this we get a beta-redex - -- every time, so the simplifier keeps doing more iterations. + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] ; arg' <- case arg of Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body cont + ; body' <- simplExprC env' body inner_cont ; return (Lam s' body') } -- Important: do not try to eta-expand this lambda -- See Note [No eta-expansion in runRW#] + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' - , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + , sc_env = env', sc_cont = inner_cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } - ; let rr' = getRuntimeRep ty' - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] - ; return (emptyFloats env, call') } + ; let rr' = getRuntimeRep new_runrw_res_ty + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] + ; rebuild env call' outer_cont } ---------- Simplify value arguments -------------------- rebuildCall env fun_info @@ -2318,7 +2328,8 @@ -- Strict arguments | isStrictArgInfo fun_info - , seCaseCase env + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty @@ -3136,7 +3147,9 @@ -------------------------------------------------- reallyRebuildCase env scrut case_bndr alts cont - | not (seCaseCase env) + | not (seCaseCase env) -- Only when case-of-case is on. + -- See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = do { case_expr <- simplAlts env scrut case_bndr alts (mkBoringStop (contHoleType cont)) ; rebuild env case_expr cont } diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs --- a/GHC/Core/Opt/SpecConstr.hs +++ b/GHC/Core/Opt/SpecConstr.hs @@ -639,6 +639,17 @@ representing strict fields. See Note [Call-by-value for worker args] for why we do this. +(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944). + We don't want to make + case M.foo_acf of M.foo_acf { DEFAULT -> blah } + because the binder of a case-expression should never be imported. Rather, + we must localise it thus: + case M.foo_acf of foo_acf { DEFAULT -> blah } + We keep the same unique, so in the next round of simplification we'll replace + any M.foo_acf's in `blah` by `foo_acf`. + + c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils. + Note [Specialising on dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In #21386, SpecConstr saw this call: @@ -2028,8 +2039,8 @@ | otherwise = return (extra_qvs, pat) --- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr +-- See Note [SpecConstr and strict fields] mkSeqs seqees res_ty rhs = foldr addEval rhs seqees where @@ -2037,7 +2048,11 @@ addEval arg_id rhs -- Argument representing strict field and it's worth passing via cbv | shouldStrictifyIdForCbv arg_id - = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs]) + = Case (Var arg_id) + (localiseId arg_id) -- See (SCF1) in Note [SpecConstr and strict fields] + res_ty + ([Alt DEFAULT [] rhs]) + | otherwise = rhs diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -1485,11 +1485,12 @@ -- This is important: see Note [Update unfolding after specialisation] -- And in any case cloneBndrSM discards non-Stable unfoldings - fn3 = zapIdDemandInfo fn2 + fn3 = floatifyIdDemandInfo fn2 -- We zap the demand info because the binding may float, -- which would invalidate the demand info (see #17810 for example). -- Destroying demand info is not terrible; specialisation is -- always followed soon by demand analysis. + -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds `extendInScope` fn3 diff --git a/GHC/Core/TyCo/Compare.hs b/GHC/Core/TyCo/Compare.hs --- a/GHC/Core/TyCo/Compare.hs +++ b/GHC/Core/TyCo/Compare.hs @@ -12,8 +12,9 @@ nonDetCmpTypesX, nonDetCmpTc, eqVarBndrs, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTyConApps, + mayLookIdentical, -- * Visiblity comparision eqForAllVis, cmpForAllVis @@ -22,7 +23,8 @@ import GHC.Prelude -import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe ) +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe + , isLevityTy, isRuntimeRepTy, isMultiplicityTy ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -129,52 +131,119 @@ See #19226. -} +mayLookIdentical :: Type -> Type -> Bool +-- | Returns True if the /visible/ part of the types +-- might look equal, even if they are really unequal (in the invisible bits) +-- +-- This function is very similar to tc_eq_type but it is much more +-- heuristic. Notably, it is always safe to return True, even with types +-- that might (in truth) be unequal -- this affects error messages only +-- (Originally there were one function with an extra flag, but the result +-- was hard to understand.) +mayLookIdentical orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + go :: RnEnv2 -> Type -> Type -> Bool + -- See Note [Comparing nullary type synonyms] + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True + + go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + && go (rnBndr2 env tv1 tv2) ty1 ty2 + -- Visible stuff only: ignore kinds of binders + + -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond + -- with True. Reason: the type pretty-printer defaults RuntimeRep + -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make, + -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the + -- same as a very different type (#24553). By responding True, we + -- tell GHC (see calls of mayLookIdentical) to display without defaulting. + -- See Note [Showing invisible bits of types in error messages] + -- in GHC.Tc.Errors.Ppr + go _ (ForAllTy b _) _ | isDefaultableBndr b = True + go _ _ (ForAllTy b _) | isDefaultableBndr b = True + + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env arg1 arg2 && go env res1 res2 && go env w1 w2 + -- Visible stuff only: ignore agg kinds + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2 + + go _ _ _ = False + + gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool + gos _ _ [] [] = True + gos env bs (t1:ts1) (t2:ts2) + | (invisible, bs') <- case bs of + [] -> (False, []) + (b:bs) -> (isInvisibleTyConBinder b, bs) + = (invisible || go env t1 t2) && gos env bs' ts1 ts2 + + gos _ _ _ _ = False + + -- | Type equality comparing both visible and invisible arguments and expanding -- type synonyms. tcEqTypeNoSyns :: Type -> Type -> Bool -tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb - --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: Type -> Type -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 +tcEqTypeNoSyns ta tb = tc_eq_type False ta tb -- | Like 'pickyEqTypeVis', but returns a Bool for convenience pickyEqType :: Type -> Type -> Bool -- Check when two types _look_ the same, _including_ synonyms. -- So (pickyEqType String [Char]) returns False -- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 +pickyEqType ty1 ty2 = tc_eq_type True ty1 ty2 -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only -> Type -> Type -> Bool -- Flags False, False is the usual setting for tc_eq_type -- See Note [Computing equality on types] in Type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 +{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. +tc_eq_type keep_syns orig_ty1 orig_ty2 = go orig_env orig_ty1 orig_ty2 where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + go :: RnEnv2 -> Type -> Type -> Bool - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. - go _ (TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = True + -- See Note [Comparing nullary type synonyms] + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2 go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2' - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 - - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True go env (ForAllTy (Bndr tv1 vis1) ty1) (ForAllTy (Bndr tv2 vis2) ty2) = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] - && (vis_only || go env (varType tv1) (varType tv2)) + && go env (varType tv1) (varType tv2) && go (rnBndr2 env tv1 tv2) ty1 ty2 -- Make sure we handle all FunTy cases since falling through to the @@ -183,11 +252,9 @@ -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check -- kinds here go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) - = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 - where - kinds_eq | vis_only = True - | otherwise = go env (typeKind arg1) (typeKind arg2) && - go env (typeKind res1) (typeKind res2) + = go env (typeKind arg1) (typeKind arg2) && + go env (typeKind res1) (typeKind res2) && + go env arg1 arg2 && go env res1 res2 && go env w1 w2 -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2 @@ -198,32 +265,24 @@ = go env s1 s2 && go env t1 t2 go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True + = tc1 == tc2 && gos env ts1 ts2 go _ _ _ = False - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. - +isDefaultableBndr :: ForAllTyBinder -> Bool +-- This function should line up with the defaulting done +-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind +-- See Note [Showing invisible bits of types in error messages] +-- in GHC.Tc.Errors.Ppr +isDefaultableBndr (Bndr tv vis) + = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv) + where + is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function @@ -543,7 +602,7 @@ -- Returns both the resulting ordering relation between -- the two types and whether either contains a cast. go :: RnEnv2 -> Type -> Type -> TypeOrdering - -- See Note [Comparing nullary type synonyms]. + -- See Note [Comparing nullary type synonyms] go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = TEQ diff --git a/GHC/Core/TyCo/Ppr.hs b/GHC/Core/TyCo/Ppr.hs --- a/GHC/Core/TyCo/Ppr.hs +++ b/GHC/Core/TyCo/Ppr.hs @@ -14,7 +14,7 @@ pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, - pprDataCons, pprWithExplicitKindsWhen, + pprDataCons, pprWithInvisibleBitsWhen, pprWithTYPE, pprSourceTyCon, @@ -330,13 +330,14 @@ -- TODO: toIfaceTcArgs seems rather wasteful here ------------------ --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b +-- | Display all foralls, runtime-reps, and kind information +-- when provided 'Bool' argument is 'True'. See GHC.Tc.Errors.Ppr +-- Note [Showing invisible bits of types in error messages] +pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc +pprWithInvisibleBitsWhen b = updSDocContext $ \ctx -> - if b then ctx { sdocPrintExplicitKinds = True } + if b then ctx { sdocPrintExplicitKinds = True + , sdocPrintExplicitRuntimeReps = True } else ctx -- | This variant preserves any use of TYPE in a type, effectively diff --git a/GHC/Core/TyCo/Rep.hs b/GHC/Core/TyCo/Rep.hs --- a/GHC/Core/TyCo/Rep.hs +++ b/GHC/Core/TyCo/Rep.hs @@ -1190,6 +1190,24 @@ The Int in the AxiomInstCo constructor is the 0-indexed number of the chosen branch. +Note [Required foralls in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty). +It has type + forall a. e_ty +Note the Specified visibility of (forall a. e_ty); the Core type just isn't able +to express more than one visiblity, and we pick `Specified`. See `exprType` and +`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreLamForAllTyFlag`. + +So how can we ever get a term of type (forall a -> e_ty)? Answer: /only/ via a +cast built with ForAllCo. See `GHC.Tc.Types.Evidence.mkWpForAllCast`. This does +not seem very satisfying, but it does the job. + +An alternative would be to put a visibility flag into `Lam` (a huge change), +or into a `TyVar` (a more plausible change), but we leave that for the future. + +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + Note [ForAllCo] ~~~~~~~~~~~~~~~ See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. @@ -1246,10 +1264,7 @@ in the typing rule. See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. -(FC4) A lambda term (Lam a e) has type (forall a. ty), with visibility - flag `GHC.Type.Var.coreTyLamForAllTyFlag`, not (forall a -> ty). - See `GHC.Type.Var.coreTyLamForAllTyFlag` and `GHC.Core.Utils.mkLamType`. - The only way to get a term of type (forall a -> ty) is to cast a lambda. +(FC4) See Note [Required foralls in Core]. (FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy] diff --git a/GHC/Core/TyCo/Subst.hs b/GHC/Core/TyCo/Subst.hs --- a/GHC/Core/TyCo/Subst.hs +++ b/GHC/Core/TyCo/Subst.hs @@ -62,7 +62,7 @@ , mkCoercionType , coercionKind, coercionLKind, coVarKindsTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) -import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -1954,6 +1954,8 @@ _ -> False -- | Is this a function? +-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function. +-- It would merely be a forall wrapping a function type. isFunTy :: Type -> Bool isFunTy ty | FunTy {} <- coreFullView ty = True diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -1066,7 +1066,7 @@ -- Respects newtypes, PredTypes -- See Note [Computing equality on types] in GHC.Core.Type unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. + -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare | tc1 == tc2 = return () diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -168,7 +168,7 @@ mkLamType v body_ty | isTyVar v = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty - -- coreTyLamForAllTyFlag: see (FC4) in Note [ForAllCo] + -- coreTyLamForAllTyFlag: see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep | isCoVar v diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs --- a/GHC/CoreToStg/Prep.hs +++ b/GHC/CoreToStg/Prep.hs @@ -14,7 +14,6 @@ , CorePrepPgmConfig (..) , corePrepPgm , corePrepExpr - , mkConvertNumLiteral ) where @@ -24,11 +23,13 @@ import GHC.Driver.Flags -import GHC.Tc.Utils.Env import GHC.Unit import GHC.Builtin.Names +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Types +import GHC.Builtin.Types.Prim import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -60,14 +61,16 @@ import GHC.Types.Id.Info import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic -import GHC.Types.Name ( Name, NamedThing(..), nameSrcSpan, isInternalName ) +import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish -import GHC.Types.TyThing import GHC.Types.Unique.Supply -import Data.List ( unfoldr ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import Data.ByteString.Builder.Prim + import Control.Monad {- @@ -805,11 +808,10 @@ = return (emptyFloats, Type (cpSubstTy env ty)) cpeRhsE env (Coercion co) = return (emptyFloats, Coercion (cpSubstCo env co)) -cpeRhsE env expr@(Lit (LitNumber nt i)) - = case cp_convertNumLit (cpe_config env) nt i of - Nothing -> return (emptyFloats, expr) - Just e -> cpeRhsE env e -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Lit lit) + | LitNumber LitNumBigNat i <- lit + = cpeBigNatLit env i + | otherwise = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(App {}) = cpeApp env expr @@ -1548,7 +1550,7 @@ -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep] | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2 - , not (has_join_in_tail_context arg) + , not (eta_would_wreck_join arg) -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] = case exprEtaExpandArity ao arg of Nothing -> 0 @@ -1557,15 +1559,15 @@ | otherwise = exprArity arg -- this is cheap enough for -O0 -has_join_in_tail_context :: CoreExpr -> Bool +eta_would_wreck_join :: CoreExpr -> Bool -- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in -- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] -has_join_in_tail_context (Let bs e) = isJoinBind bs || has_join_in_tail_context e -has_join_in_tail_context (Lam b e) | isTyVar b = has_join_in_tail_context e -has_join_in_tail_context (Cast e _) = has_join_in_tail_context e -has_join_in_tail_context (Tick _ e) = has_join_in_tail_context e -has_join_in_tail_context (Case _ _ _ alts) = any has_join_in_tail_context (rhssOfAlts alts) -has_join_in_tail_context _ = False +eta_would_wreck_join (Let bs e) = isJoinBind bs || eta_would_wreck_join e +eta_would_wreck_join (Lam _ e) = eta_would_wreck_join e +eta_would_wreck_join (Cast e _) = eta_would_wreck_join e +eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e +eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts) +eta_would_wreck_join _ = False maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks @@ -1698,7 +1700,8 @@ (EA1) When eta expanding an argument headed by a join point, we might get "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts - it. + it. This crap means the output does not conform to the syntax in + Note [CorePrep invariants], which then makes later passes crash (#25033). Consider f (join j x = rhs in ...(j 1)...(j 2)...) @@ -1713,16 +1716,23 @@ In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App case of `coreToStgExpr`. - Hence we simply check for the cases where an intervening join point - binding in the tail context of the argument would lead to the introduction - of such crap via `has_join_in_tail_context`, in which case we abstain from - eta expansion. + Hence, in `eta_would_wreck_join`, we check for the cases where an + intervening join point binding in the tail context of the argument would + make eta-expansion break Note [CorePrep invariants], in which + case we abstain from eta expansion. + This scenario occurs rarely; hence it's OK to generate sub-optimal code. The alternative would be to fix Note [Eta expansion for join points], but that's quite challenging due to unfoldings of (recursive) join points. -(EA2) In cpeArgArity, if float_decision = FloatNone) the `arg` will look like + `eta_would_wreck_join` sees if there are any join points, like `j` above + that would be messed up. It must look inside lambdas (#25033); consider + f (\x. join j y = ... in ...(j 1)...(j 3)...) + We can't eta expand that `\x` any more than we could if the join was at + the top. (And when there's a lambda, we don't have a thunk anyway.) + +(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like let in rhs where is non-empty and can't be floated out of a lazy context (see `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0 @@ -1894,6 +1904,16 @@ See also Note [Floats and FloatDecision] for how we maintain whole groups of floats and how far they go. +Note [Controlling Speculative Evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Most of the time, speculative evaluation has a positive effect on performance, +but we have found a case where speculative evaluation of dictionary functions +leads to a performance regression #25284. + +Therefore we have some flags to control it. See the optimization section in +the User's Guide for the description of these flags and when to use them. + Note [Floats and FloatDecision] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have a special datatype `Floats` for modelling a telescope of `FloatingBind` @@ -2068,7 +2088,15 @@ is_lifted = not is_unlifted is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd - ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs + cfg = cpe_config env + + ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs + -- See Note [Controlling Speculative Evaluation] + call_ok_for_spec x + | is_rec_call x = False + | not (cp_specEval cfg) = False + | not (cp_specEvalDFun cfg) && isDFunId x = False + | otherwise = True is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe @@ -2293,14 +2321,17 @@ -- cases. This is helpful when debugging demand analysis or type -- checker bugs which can sometimes manifest as segmentation faults. - , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) - -- ^ Convert some numeric literals (Integer, Natural) into their final - -- Core form. + , cp_platform :: Platform , cp_arityOpts :: !(Maybe ArityOpts) -- ^ Configuration for arity analysis ('exprEtaExpandArity'). -- See Note [Eta expansion of arguments in CorePrep] -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead + , cp_specEval :: !Bool + -- ^ Whether to perform speculative evaluation + -- See Note [Controlling Speculative Evaluation] + , cp_specEvalDFun :: !Bool + -- ^ Whether to perform speculative evaluation on DFuns } data CorePrepEnv @@ -2532,57 +2563,119 @@ -- Numeric literals -- --------------------------------------------------------------------------- --- | Create a function that converts Bignum literals into their final CoreExpr -mkConvertNumLiteral - :: Platform - -> HomeUnit - -> (Name -> IO TyThing) - -> IO (LitNumType -> Integer -> Maybe CoreExpr) -mkConvertNumLiteral platform home_unit lookup_global = do - let - guardBignum act - | isHomeUnitInstanceOf home_unit primUnitId - = return $ panic "Bignum literals are not supported in ghc-prim" - | isHomeUnitInstanceOf home_unit bignumUnitId - = return $ panic "Bignum literals are not supported in ghc-bignum" - | otherwise = act +-- | Converts Bignum literals into their final CoreExpr +cpeBigNatLit + :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) +cpeBigNatLit env i = assert (i >= 0) $ do + let + platform = cp_platform (cpe_config env) - lookupBignumId n = guardBignum (tyThingId <$> lookup_global n) + -- Per the documentation in GHC.Num.BigNat, a BigNat# is: + -- "Represented as an array of limbs (Word#) stored in + -- little-endian order (Word# themselves use machine order)." + -- + -- "Invariant (canonical representation): higher Word# is non-zero." + -- So we need to break up the integer into target-word-sized chunks, + -- and encode each of them using the target's byte-order. + encodeBigNat + :: forall a. Num a => FixedPrim a -> BS.ByteString + encodeBigNat encodeWord + = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i)) + -- (quadratic complexity due to repeated shifts... ok for now) + where + f 0 = Nothing + f x = let low = fromInteger x :: a + high = x `shiftR` bits + in Just (low, high) + bits = platformWordSizeInBits platform - -- The lookup is done here but the failure (panic) is reported lazily when we - -- try to access the `bigNatFromWordList` function. - -- - -- If we ever get built-in ByteArray# literals, we could avoid the lookup by - -- directly using the Integer/Natural wired-in constructors for big numbers. + words :: BS.ByteString + words = case (platformWordSize platform, platformByteOrder platform) of + (PW4, LittleEndian) -> encodeBigNat word32LE + (PW4, BigEndian ) -> encodeBigNat word32BE + (PW8, LittleEndian) -> encodeBigNat word64LE + (PW8, BigEndian ) -> encodeBigNat word64BE - bignatFromWordListId <- lookupBignumId bignatFromWordListName + -- Ideally we would just generate a ByteArray# literal here: + -- pure (emptyFloats, Lit (LitByteArray words)) + -- But sadly we don't have those yet, even in Core. (See also #17747.) + -- So instead we generate: + -- * An `Addr#` literal that contains the contents of the + -- `ByteArray#` we want to create. This gets its own float. + -- * A call to `newByteArray#` with the appropriate size + -- * A call to `copyAddrToByteArray#` to initialize the `ByteArray#` + -- * A call to `unsafeFreezeByteArray#` to make the types match + litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy + -- returned from newByteArray#: + deadNewByteArrayTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [ realWorldStatePrimTy + , realWorldMutableByteArrayPrimTy + ] + stateTokenFromNewByteArrayId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + mutableByteArrayId + <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy + -- returned from copyAddrToByteArray#: + stateTokenFromCopyId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + -- returned from unsafeFreezeByteArray#: + deadFreezeTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy] + stateTokenFromFreezeId + <- (`setIdOccInfo` IAmDead) <$> + mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy - let - convertNumLit nt i = case nt of - LitNumBigNat -> Just (convertBignatPrim i) - _ -> Nothing + let + litAddrRhs = Lit (LitString words) + -- not "mkLitString"; that does UTF-8 encoding, which we don't want here + litAddrFloat = mkNonRecFloat env topDmd True litAddrId litAddrRhs - convertBignatPrim i = - let - -- ByteArray# literals aren't supported (yet). Were they supported, - -- we would use them directly. We would need to handle - -- wordSize/endianness conversion between host and target - -- wordSize = platformWordSize platform - -- byteOrder = platformByteOrder platform + contentsLength = mkIntLit platform (toInteger (BS.length words)) - -- For now we build a list of Words and we produce - -- `bigNatFromWordList# list_of_words` + newByteArrayCall = + Var (primOpId NewByteArrayOp_Char) + `App` Type realWorldTy + `App` contentsLength + `App` Var realWorldPrimId - words = mkListExpr wordTy (reverse (unfoldr f i)) - where - f 0 = Nothing - f x = let low = x .&. mask - high = x `shiftR` bits - in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high) - bits = platformWordSizeInBits platform - mask = 2 ^ bits - 1 + copyContentsCall = + Var (primOpId CopyAddrToByteArrayOp) + `App` Type realWorldTy + `App` Var litAddrId + `App` Var mutableByteArrayId + `App` mkIntLit platform 0 + `App` contentsLength + `App` Var stateTokenFromNewByteArrayId - in mkApps (Var bignatFromWordListId) [words] + unsafeFreezeCall = + Var (primOpId UnsafeFreezeByteArrayOp) + `App` Type realWorldTy + `App` Var mutableByteArrayId + `App` Var stateTokenFromCopyId + unboxed2tuple_altcon :: AltCon + unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2) - return convertNumLit + finalRhs = + Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromNewByteArrayId, mutableByteArrayId] + copyContentsCase + ] + + copyContentsCase = + Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy + [ Alt DEFAULT [] unsafeFreezeCase + ] + + unsafeFreezeCase = + Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromFreezeId, byteArrayId] + (Var byteArrayId) + ] + + pure (emptyFloats `snocFloat` litAddrFloat, finalRhs) diff --git a/GHC/Data/FlatBag.hs b/GHC/Data/FlatBag.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FlatBag.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE UnboxedTuples #-} +module GHC.Data.FlatBag + ( FlatBag + , emptyFlatBag + , unitFlatBag + , sizeFlatBag + , elemsFlatBag + , mappendFlatBag + -- * Construction + , fromList + , fromSizedSeq + ) where + +import GHC.Prelude + +import GHC.Data.SizedSeq (SizedSeq, ssElts, sizeSS) + +import Control.DeepSeq + +import GHC.Data.SmallArray + +-- | Store elements in a flattened representation. +-- +-- A 'FlatBag' is a data structure that stores an ordered list of elements +-- in a flat structure, avoiding the overhead of a linked list. +-- Use this data structure, if the code requires the following properties: +-- +-- * Elements are stored in a long-lived object, and benefit from a flattened +-- representation. +-- * The 'FlatBag' will be traversed but not extended or filtered. +-- * The number of elements should be known. +-- * Sharing of the empty case improves memory behaviour. +-- +-- A 'FlagBag' aims to have as little overhead as possible to store its elements. +-- To achieve that, it distinguishes between the empty case, singleton, tuple +-- and general case. +-- Thus, we only pay for the additional three words of an 'Array' if we have at least +-- three elements. +data FlatBag a + = EmptyFlatBag + | UnitFlatBag !a + | TupleFlatBag !a !a + | FlatBag {-# UNPACK #-} !(SmallArray a) + +instance Functor FlatBag where + fmap _ EmptyFlatBag = EmptyFlatBag + fmap f (UnitFlatBag a) = UnitFlatBag $ f a + fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b) + fmap f (FlatBag e) = FlatBag $ mapSmallArray f e + +instance Foldable FlatBag where + foldMap _ EmptyFlatBag = mempty + foldMap f (UnitFlatBag a) = f a + foldMap f (TupleFlatBag a b) = f a `mappend` f b + foldMap f (FlatBag arr) = foldMapSmallArray f arr + + length = fromIntegral . sizeFlatBag + +instance Traversable FlatBag where + traverse _ EmptyFlatBag = pure EmptyFlatBag + traverse f (UnitFlatBag a) = UnitFlatBag <$> f a + traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b + traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl) + +instance NFData a => NFData (FlatBag a) where + rnf EmptyFlatBag = () + rnf (UnitFlatBag a) = rnf a + rnf (TupleFlatBag a b) = rnf a `seq` rnf b + rnf (FlatBag arr) = rnfSmallArray arr + +-- | Create an empty 'FlatBag'. +-- +-- The empty 'FlatBag' is shared over all instances. +emptyFlatBag :: FlatBag a +emptyFlatBag = EmptyFlatBag + +-- | Create a singleton 'FlatBag'. +unitFlatBag :: a -> FlatBag a +unitFlatBag = UnitFlatBag + +-- | Calculate the size of +sizeFlatBag :: FlatBag a -> Word +sizeFlatBag EmptyFlatBag = 0 +sizeFlatBag UnitFlatBag{} = 1 +sizeFlatBag TupleFlatBag{} = 2 +sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr + +-- | Get all elements that are stored in the 'FlatBag'. +elemsFlatBag :: FlatBag a -> [a] +elemsFlatBag EmptyFlatBag = [] +elemsFlatBag (UnitFlatBag a) = [a] +elemsFlatBag (TupleFlatBag a b) = [a, b] +elemsFlatBag (FlatBag arr) = + [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]] + +-- | Combine two 'FlatBag's. +-- +-- The new 'FlatBag' contains all elements from both 'FlatBag's. +-- +-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused. +mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a +mappendFlatBag EmptyFlatBag b = b +mappendFlatBag a EmptyFlatBag = a +mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b +mappendFlatBag a b = + fromList (sizeFlatBag a + sizeFlatBag b) + (elemsFlatBag a ++ elemsFlatBag b) + +-- | Store the list in a flattened memory representation, avoiding the memory overhead +-- of a linked list. +-- +-- The size 'n' needs to be smaller or equal to the length of the list. +-- If it is smaller than the length of the list, overflowing elements are +-- discarded. It is undefined behaviour to set 'n' to be bigger than the +-- length of the list. +fromList :: Word -> [a] -> FlatBag a +fromList n elts = + case elts of + [] -> EmptyFlatBag + [a] -> UnitFlatBag a + [a, b] -> TupleFlatBag a b + xs -> + FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs)) + +-- | Convert a 'SizedSeq' into its flattened representation. +-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification +-- is necessary. +fromSizedSeq :: SizedSeq a -> FlatBag a +fromSizedSeq s = fromList (sizeSS s) (ssElts s) diff --git a/GHC/Data/SmallArray.hs b/GHC/Data/SmallArray.hs --- a/GHC/Data/SmallArray.hs +++ b/GHC/Data/SmallArray.hs @@ -11,13 +11,18 @@ , freezeSmallArray , unsafeFreezeSmallArray , indexSmallArray + , sizeofSmallArray , listToArray + , mapSmallArray + , foldMapSmallArray + , rnfSmallArray ) where import GHC.Exts import GHC.Prelude import GHC.ST +import Control.DeepSeq data SmallArray a = SmallArray (SmallArray# a) @@ -64,6 +69,14 @@ case unsafeFreezeSmallArray# ma s of (# s', a #) -> (# s', SmallArray a #) +-- | Get the size of a 'SmallArray' +sizeofSmallArray + :: SmallArray a + -> Int +{-# INLINE sizeofSmallArray #-} +sizeofSmallArray (SmallArray sa#) = + case sizeofSmallArray# sa# of + s -> I# s -- | Index a small-array (no bounds checking!) indexSmallArray @@ -71,9 +84,51 @@ -> Int -- ^ index -> a {-# INLINE indexSmallArray #-} -indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of - (# v #) -> v +indexSmallArray (SmallArray sa#) (I# i) = + case indexSmallArray# sa# i of + (# v #) -> v +-- | Map a function over the elements of a 'SmallArray' +-- +mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b +{-# INLINE mapSmallArray #-} +mapSmallArray f sa = runST $ ST $ \s -> + let + n = sizeofSmallArray sa + go !i saMut# state# + | i < n = + let + a = indexSmallArray sa i + newState# = writeSmallArray saMut# i (f a) state# + in + go (i + 1) saMut# newState# + | otherwise = state# + in + case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of + (# s', mutArr #) -> + case go 0 mutArr s' of + s'' -> unsafeFreezeSmallArray mutArr s'' + +-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice +foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m +{-# INLINE foldMapSmallArray #-} +foldMapSmallArray f sa = go 0 + where + n = sizeofSmallArray sa + go i + | i < n = f (indexSmallArray sa i) `mappend` go (i + 1) + | otherwise = mempty + +-- | Force the elements of the given 'SmallArray' +-- +rnfSmallArray :: NFData a => SmallArray a -> () +{-# INLINE rnfSmallArray #-} +rnfSmallArray sa = go 0 + where + n = sizeofSmallArray sa + go !i + | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1) + | otherwise = () -- | Convert a list into an array. listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a diff --git a/GHC/Data/Word64Map/Strict.hs b/GHC/Data/Word64Map/Strict.hs --- a/GHC/Data/Word64Map/Strict.hs +++ b/GHC/Data/Word64Map/Strict.hs @@ -248,4 +248,3 @@ ) where import GHC.Data.Word64Map.Strict.Internal -import Prelude () diff --git a/GHC/Driver/CmdLine.hs b/GHC/Driver/CmdLine.hs --- a/GHC/Driver/CmdLine.hs +++ b/GHC/Driver/CmdLine.hs @@ -31,7 +31,7 @@ import GHC.Types.Error import GHC.Utils.Error import GHC.Driver.Errors.Types -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage import GHC.Utils.Outputable (text) import Data.Function diff --git a/GHC/Driver/Config/Core/Opt/Simplify.hs b/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better + -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -89,3 +90,37 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled + + +{- Note [Case-of-case and full laziness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case-of-case can hide opportunities for let-floating (full laziness). +For example + rec { f = \y. case (expensive x) of (a,b) -> blah } +We might hope to float the (expensive x) out of the \y-loop. +But if we inline `expensive` we might get + \y. case (case x of I# x' -> body) of (a,b) -> blah +Now if we do case-of-case we get + \y. case x if I# x2 -> + case body of (a,b) -> blah + +Sadly, at this point `body` mentions `x2`, so we can't float it out of the +\y-loop. + +Solution: don't do case-of-case in the "gentle" simplification phase that +precedes the first float-out transformation. Implementation: + + * `sm_case_case` field in SimplMode + + * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case + in GHC.Core.Opt.Simplify.Iteration.rebuildCall. + +Wrinkles + +* This applies equally to the case-of-runRW# transformation: + case (runRW# (\s. body)) of (a,b) -> blah + ---> + runRW# (\s. case body of (a,b) -> blah) + Again, don't do this when `sm_case_case` is off. See #25055 for + a motivating example. +-} diff --git a/GHC/Driver/Config/CoreToStg/Prep.hs b/GHC/Driver/Config/CoreToStg/Prep.hs --- a/GHC/Driver/Config/CoreToStg/Prep.hs +++ b/GHC/Driver/Config/CoreToStg/Prep.hs @@ -10,7 +10,6 @@ import GHC.Driver.Session import GHC.Driver.Config.Core.Lint import GHC.Driver.Config.Core.Opt.Arity -import GHC.Tc.Utils.Env import GHC.Types.Var import GHC.Utils.Outputable ( alwaysQualify ) @@ -19,17 +18,14 @@ initCorePrepConfig :: HscEnv -> IO CorePrepConfig initCorePrepConfig hsc_env = do let dflags = hsc_dflags hsc_env - convertNumLit <- do - let platform = targetPlatform dflags - home_unit = hsc_home_unit hsc_env - lookup_global = lookupGlobal hsc_env - mkConvertNumLiteral platform home_unit lookup_global return $ CorePrepConfig { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags - , cp_convertNumLit = convertNumLit + , cp_platform = targetPlatform dflags , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags then Just (initArityOpts dflags) else Nothing + , cp_specEval = gopt Opt_SpecEval dflags + , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags } initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig diff --git a/GHC/Driver/Config/Diagnostic.hs b/GHC/Driver/Config/Diagnostic.hs --- a/GHC/Driver/Config/Diagnostic.hs +++ b/GHC/Driver/Config/Diagnostic.hs @@ -19,7 +19,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- Diagnostic instances import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error diff --git a/GHC/Driver/Config/StgToCmm.hs b/GHC/Driver/Config/StgToCmm.hs --- a/GHC/Driver/Config/StgToCmm.hs +++ b/GHC/Driver/Config/StgToCmm.hs @@ -14,6 +14,7 @@ import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile +import GHC.Platform.Regs import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable @@ -76,13 +77,16 @@ | otherwise -> const True - , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm + , stgToCmmAllowIntMul2Instr = (ncg && (x86ish || aarch64)) || llvm + , stgToCmmAllowWordMul2Instr = (ncg && (x86ish || ppc || aarch64)) || llvm -- SIMD flags , stgToCmmVecInstrsErr = vec_err , stgToCmmAvx = isAvxEnabled dflags , stgToCmmAvx2 = isAvx2Enabled dflags , stgToCmmAvx512f = isAvx512fEnabled dflags , stgToCmmTickyAP = gopt Opt_Ticky_AP dflags + -- See Note [Saving foreign call target to local] + , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform } where profile = targetProfile dflags platform = profilePlatform profile bk_end = backend dflags @@ -92,6 +96,9 @@ JSPrimitives -> (False, False) NcgPrimitives -> (True, False) LlvmPrimitives -> (False, True) + aarch64 = case platformArch platform of + ArchAArch64 -> True + _ -> False x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True diff --git a/GHC/Driver/DynFlags.hs b/GHC/Driver/DynFlags.hs --- a/GHC/Driver/DynFlags.hs +++ b/GHC/Driver/DynFlags.hs @@ -1300,6 +1300,8 @@ -- RegsGraph suffers performance regression. See #7679 -- , ([2], Opt_StaticArgumentTransformation) -- Static Argument Transformation needs investigation. See #9374 + , ([0,1,2], Opt_SpecEval) + , ([0,1,2], Opt_SpecEvalDictFun) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on diff --git a/GHC/Driver/Errors/Ppr.hs b/GHC/Driver/Errors/Ppr.hs --- a/GHC/Driver/Errors/Ppr.hs +++ b/GHC/Driver/Errors/Ppr.hs @@ -14,8 +14,8 @@ import GHC.Driver.Errors.Types import GHC.Driver.Flags import GHC.Driver.DynFlags -import GHC.HsToCore.Errors.Ppr () -import GHC.Parser.Errors.Ppr () +import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage +import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage import GHC.Types.Error import GHC.Types.Error.Codes import GHC.Unit.Types @@ -30,8 +30,8 @@ import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) import GHC.Iface.Errors.Types -import GHC.Tc.Errors.Ppr () -import GHC.Iface.Errors.Ppr () +import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage +import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage -- -- Suggestions diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -316,7 +316,10 @@ | Opt_NumConstantFolding | Opt_CoreConstantFolding | Opt_FastPAPCalls -- #6084 + | Opt_SpecEval + | Opt_SpecEvalDictFun -- See Note [Controlling Speculative Evaluation] + -- Inference flags | Opt_DoTagInferenceChecks @@ -550,6 +553,8 @@ , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + , Opt_SpecEval + , Opt_SpecEvalDictFun ] -- | The set of flags which affect code generation and can change a program's diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs --- a/GHC/Driver/Hooks.hs +++ b/GHC/Driver/Hooks.hs @@ -154,8 +154,6 @@ -> IO (Stream IO RawCmmGroup a))) } -{-# DEPRECATED cmmToRawCmmHook "cmmToRawCmmHook is being deprecated. If you do use it in your project, please raise a GHC issue!" #-} - class HasHooks m where getHooks :: m Hooks diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -6,9 +6,6 @@ {-# OPTIONS_GHC -fprof-auto-top #-} --- Remove this after cmmToRawCmmHook removal -{-# OPTIONS_GHC -Wno-deprecations #-} - ------------------------------------------------------------------------------- -- -- | Main API for compiling plain Haskell source code. @@ -1805,7 +1802,7 @@ if gopt Opt_ProfLateInlineCcs dflags then LateCCNone else if gopt Opt_ProfLateCcs dflags then - LateCCAllBinds + LateCCBinds else if gopt Opt_ProfLateOverloadedCcs dflags then LateCCOverloadedBinds else @@ -2665,7 +2662,7 @@ case interp of -- always generate JS code for the JS interpreter (no bytecode!) - Interp (ExternalInterp (ExtJS i)) _ -> + Interp (ExternalInterp (ExtJS i)) _ _ -> jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id _ -> do diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -299,16 +299,16 @@ -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes user doesn't want GHC to pick up modules, not explicitly listed --- in a command line. For example, cabal may want to enable this warning --- when building a library, so that GHC warns user about modules, not listed --- neither in `exposed-modules`, nor in `other-modules`. +-- Sometimes we don't want GHC to process modules that weren't specified as +-- explicit targets. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns the user about modules listed +-- neither in `exposed-modules` nor in `other-modules`. -- --- Here "home module" means a module, that doesn't come from an other package. +-- Here "home module" means a module that doesn't come from another package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in a command line. +-- about module "C" not being listed in the command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages @@ -319,8 +319,6 @@ where diag_opts = initDiagOpts dflags - is_known_module mod = any (is_my_target mod) targets - -- We need to be careful to handle the case where (possibly -- path-qualified) filenames (aka 'TargetFile') rather than module -- names are being passed on the GHC command-line. @@ -329,27 +327,31 @@ -- `ghc --make -isrc-exe Main` are supposed to be equivalent. -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727. - is_my_target mod target = - let tuid = targetUnitId target - in case targetId target of - TargetModule name - -> moduleName (ms_mod mod) == name - && tuid == ms_unitid mod - TargetFile target_file _ - | Just mod_file <- ml_hs_file (ms_location mod) - -> - augmentByWorkingDirectory dflags target_file == mod_file || + is_known_module mod = + is_module_target mod + || + maybe False is_file_target (ml_hs_file (ms_location mod)) - -- Don't warn on B.hs-boot if B.hs is specified (#16551) - addBootSuffix target_file == mod_file || + is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets - -- We can get a file target even if a module name was - -- originally specified in a command line because it can - -- be converted in guessTarget (by appending .hs/.lhs). - -- So let's convert it back and compare with module name - mkModuleName (fst $ splitExtension target_file) - == moduleName (ms_mod mod) - _ -> False + is_file_target file = Set.member (withoutExt file) file_targets + + file_targets = Set.fromList (mapMaybe file_target targets) + + file_target Target {targetId} = + case targetId of + TargetModule _ -> Nothing + TargetFile file _ -> + Just (withoutExt (augmentByWorkingDirectory dflags file)) + + mod_targets = Set.fromList (mod_target <$> targets) + + mod_target Target {targetUnitId, targetId} = + case targetId of + TargetModule name -> (name, targetUnitId) + TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) + + withoutExt = fst . splitExtension missing = map (moduleName . ms_mod) $ filter (not . is_known_module) $ diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -542,28 +542,28 @@ compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + let offset_file = augmentByWorkingDirectory dflags src + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase offset_file mb_phase output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase - let - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - notStopPreprocess | StopPreprocess <- stop_phase = False - | _ <- stop_phase = True - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile - -- avoid -E -fno-code undesirable interactions. see #20439 - | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - pipe_env = mkPipeEnv stop_phase src mb_phase output - pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase + exists <- doesFileExist offset_file + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) runPipeline (hsc_hooks hsc_env) pipeline diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/GHC/Driver/Pipeline/Execute.hs @@ -121,8 +121,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts - { useHsCpp = False - , cppLinePragmas = True + { sourceCodePreprocessor = SCPCmmCpp + , cppLinePragmas = True }) input_fn output_fn return output_fn @@ -652,8 +652,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts - { useHsCpp = True - , cppLinePragmas = True + { sourceCodePreprocessor = SCPHsCpp + , cppLinePragmas = True }) input_fn output_fn return output_fn @@ -964,7 +964,11 @@ attrs :: String attrs = intercalate "," $ mattr - ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse4.2" | isSse4_2Enabled dflags ] + ++ ["+popcnt" | isSse4_2Enabled dflags ] + -- LLVM gates POPCNT instructions behind the popcnt flag, + -- while the GHC NCG (as well as GCC, Clang) gates it + -- behind SSE4.2 instead. ++ ["+sse2" | isSse2Enabled platform ] ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] diff --git a/GHC/Driver/Plugins.hs b/GHC/Driver/Plugins.hs --- a/GHC/Driver/Plugins.hs +++ b/GHC/Driver/Plugins.hs @@ -420,12 +420,12 @@ loadExternalPluginLib path = do -- load library loadDLL path >>= \case - Just errmsg -> pprPanic "loadExternalPluginLib" - (vcat [ text "Can't load plugin library" - , text " Library path: " <> text path - , text " Error : " <> text errmsg - ]) - Nothing -> do + Left errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Right _ -> do -- resolve objects resolveObjs >>= \case True -> return () diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -112,6 +112,10 @@ sOpt_L, sOpt_P, sOpt_P_fingerprint, + sOpt_JSP, + sOpt_JSP_fingerprint, + sOpt_CmmP, + sOpt_CmmP_fingerprint, sOpt_F, sOpt_c, sOpt_cxx, @@ -134,11 +138,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, @@ -390,6 +394,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 @@ -423,6 +431,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]. @@ -431,6 +444,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 @@ -579,7 +603,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 @@ -669,6 +694,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}) @@ -677,9 +710,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 } @@ -1070,6 +1109,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" @@ -1124,6 +1167,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" @@ -2485,6 +2532,8 @@ flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "core-constant-folding" Opt_CoreConstantFolding, flagSpec "fast-pap-calls" Opt_FastPAPCalls, + flagSpec "spec-eval" Opt_SpecEval, + flagSpec "spec-eval-dictfun" Opt_SpecEvalDictFun, flagSpec "cmm-control-flow" Opt_CmmControlFlow, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, diff --git a/GHC/Hs/Type.hs b/GHC/Hs/Type.hs --- a/GHC/Hs/Type.hs +++ b/GHC/Hs/Type.hs @@ -38,6 +38,7 @@ HsWildCardBndrs(..), HsPatSigType(..), HsPSRn(..), HsTyPat(..), HsTyPatRn(..), + HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn, HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, fromMaybeContext, @@ -128,6 +129,7 @@ import Data.Data (Data) import qualified Data.Semigroup as S +import GHC.Data.Bag {- ************************************************************************ @@ -244,6 +246,51 @@ , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names } deriving Data + +-- | A variant of HsTyPatRn that uses Bags for efficient concatenation. +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRnBuilder = + HsTPRnB { + hstpb_nwcs :: Bag Name, + hstpb_imp_tvs :: Bag Name, + hstpb_exp_tvs :: Bag Name + } + +tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder +tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name} + +tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder +tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} = + mempty { + hstpb_nwcs = listToBag hsps_nwcs, + hstpb_imp_tvs = listToBag hsps_imp_tvs + } + +instance Semigroup HsTyPatRnBuilder where + HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 = + HsTPRnB + (nwcs1 `unionBags` nwcs2) + (imp_tvs1 `unionBags` imp_tvs2) + (exptvs1 `unionBags` exptvs2) + +instance Monoid HsTyPatRnBuilder where + mempty = HsTPRnB emptyBag emptyBag emptyBag + +buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn +buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} = + HsTPRn { + hstp_nwcs = bagToList hstpb_nwcs, + hstp_imp_tvs = bagToList hstpb_imp_tvs, + hstp_exp_tvs = bagToList hstpb_exp_tvs + } + +builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder +builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} = + HsTPRnB { + hstpb_nwcs = listToBag hstp_nwcs, + hstpb_imp_tvs = listToBag hstp_imp_tvs, + hstpb_exp_tvs = listToBag hstp_exp_tvs + } type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XXHsTyPat (GhcPass _) = DataConCantHappen diff --git a/GHC/Iface/Env.hs b/GHC/Iface/Env.hs --- a/GHC/Iface/Env.hs +++ b/GHC/Iface/Env.hs @@ -270,9 +270,9 @@ | (occ,uniq) <- occs `zip` uniqs] } trace_if :: Logger -> SDoc -> IO () -{-# INLINE trace_if #-} +{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities] trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc trace_hi_diffs :: Logger -> SDoc -> IO () -{-# INLINE trace_hi_diffs #-} +{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities] trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc diff --git a/GHC/Iface/Errors/Ppr.hs b/GHC/Iface/Errors/Ppr.hs --- a/GHC/Iface/Errors/Ppr.hs +++ b/GHC/Iface/Errors/Ppr.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage {-# LANGUAGE InstanceSigs #-} module GHC.Iface.Errors.Ppr diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs --- a/GHC/Iface/Load.hs +++ b/GHC/Iface/Load.hs @@ -443,9 +443,6 @@ ; case lookupIfaceByModule hug (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded - -- The (src_imp == mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if an earlier import had a before we got to real imports. I think. _ -> do { -- READ THE MODULE IN diff --git a/GHC/Iface/Recomp/Flags.hs b/GHC/Iface/Recomp/Flags.hs --- a/GHC/Iface/Recomp/Flags.hs +++ b/GHC/Iface/Recomp/Flags.hs @@ -50,13 +50,26 @@ -- see Note [Implicit include paths] includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } - -- -I, -D and -U flags affect CPP + -- -I, -D and -U flags affect Haskell C/CPP Preprocessor cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit -- normalise: eliminate spurious differences due to "./foo" vs "foo" , picPOpts dflags , opt_P_signature dflags) -- See Note [Repeated -optP hashing] + -- -I, -D and -U flags affect JavaScript C/CPP Preprocessor + js = ( map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , picPOpts dflags + , opt_JSP_signature dflags) + -- See Note [Repeated -optP hashing] + + -- -I, -D and -U flags affect C-- CPP Preprocessor + cmm = ( map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , picPOpts dflags + , opt_CmmP_signature dflags) + -- Note [path flags and recompilation] paths = [ hcSuf ] @@ -70,7 +83,10 @@ -- Other flags which affect code generation codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) + -- Did we include core for all bindings? + fat_iface = gopt Opt_WriteIfSimplifiedCore dflags + + flags = ((mainis, safeHs, lang, cpp, js, cmm), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs --- a/GHC/Iface/Syntax.hs +++ b/GHC/Iface/Syntax.hs @@ -85,7 +85,7 @@ import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary -import GHC.Utils.Binary.Typeable () +import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs --- a/GHC/Iface/Tidy.hs +++ b/GHC/Iface/Tidy.hs @@ -645,8 +645,11 @@ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc - | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make - | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | otherwise = [] + -- The 'otherwise' includes family TyCons of course, but also (less obviously) + -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + -- * type data: we don't want any code for type-only stuff (#24620) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs --- a/GHC/Iface/Type.hs +++ b/GHC/Iface/Type.hs @@ -1132,7 +1132,7 @@ -> IfaceType go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification - -- or we get the mess in #13963 + -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind = let subs' = extendFsEnv subs var substituted_ty -- Record that we should replace it with LiftedRep/Lifted/Many, diff --git a/GHC/Iface/Type.hs-boot b/GHC/Iface/Type.hs-boot --- a/GHC/Iface/Type.hs-boot +++ b/GHC/Iface/Type.hs-boot @@ -6,7 +6,7 @@ where -- Empty import to influence the compilation ordering. --- See Note [Depend on GHC.Num.Integer] in GHC.Base +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base import GHC.Base () data IfaceAppArgs diff --git a/GHC/Linker/Loader.hs b/GHC/Linker/Loader.hs --- a/GHC/Linker/Loader.hs +++ b/GHC/Linker/Loader.hs @@ -55,6 +55,7 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Iface.Load +import GHCi.Message (LoadedDLL) import GHC.ByteCode.Linker import GHC.ByteCode.Asm @@ -172,7 +173,7 @@ -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -221,8 +222,8 @@ -> SrcSpan -> [Module] -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required +-- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do --- initLoaderState (hsc_dflags hsc_env) dl let opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required @@ -512,25 +513,25 @@ DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm | platformOS platform /= OSDarwin -> + Right _ -> maybePutStrLn logger "done" + Left mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do + Left mm | otherwise -> do -- As a backup, on Darwin, try to also load a .so file -- since (apparently) some things install that way - see -- ticket #8770. let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of - Nothing -> maybePutStrLn logger "done" - Just _ -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL interp dll_path case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left mm -> preloadFailed mm lib_paths lib_spec return pls Framework framework -> @@ -614,7 +615,7 @@ -- Load the necessary packages and linkables let le = linker_env pls bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - resolved <- linkBCO interp le bco_ix root_ul_bco + resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv) @@ -677,7 +678,7 @@ , addr_env = plusNameEnv (addr_env le) bc_strs } -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs interp le2 [cbc] + new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let ce2 = extendClosureEnv (closure_env le2) nms_fhvs !pls2 = pls { linker_env = le2 { closure_env = ce2 } } @@ -858,8 +859,8 @@ changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] m <- loadDLL interp soFile case m of - Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } - Just err -> linkFail msg err + Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Left err -> linkFail msg err where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -899,7 +900,7 @@ ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) le2 = le1 { itbl_env = ie2, addr_env = ae2 } - names_and_refs <- linkSomeBCOs interp le2 cbcs + names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -914,6 +915,7 @@ -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp + -> PkgsLoaded -> LinkerEnv -> [CompiledByteCode] -> IO [(Name,HValueRef)] @@ -921,7 +923,7 @@ -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs interp le mods = foldr fun do_link mods [] +linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum) @@ -930,7 +932,7 @@ let flat = [ bco | bcos <- mods, bco <- bcos ] names = map unlinkedBCOName flat bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO interp le bco_ix bco | bco <- flat ] + resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1092,18 +1094,18 @@ -- Link dependents first ; pkgs' <- link pkgs deps -- Now link the package itself - ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg + ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) } + ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env @@ -1145,7 +1147,9 @@ let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] + let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] + known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] + known_dlls = known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL) dlls = [ dll | DLL dll <- classifieds ] #endif @@ -1166,10 +1170,13 @@ loadFrameworks interp platform pkg -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn interp hsc_env True) known_dlls + mapM_ (load_dyn interp hsc_env True) known_extra_dlls + loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls +#else + let loaded_dlls = [] #endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link @@ -1189,7 +1196,7 @@ if succeeded ok then do maybePutStrLn logger "done." - return (hs_classifieds, extra_classifieds) + return (hs_classifieds, extra_classifieds, loaded_dlls) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1242,19 +1249,20 @@ -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, -- loadDLL is going to search the system paths to find the library. -load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO () +load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) load_dyn interp hsc_env crash_early dll = do r <- loadDLL interp dll case r of - Nothing -> return () - Just err -> + Right loaded_dll -> pure (Just loaded_dll) + Left err -> if crash_early then cmdLineErrorIO err - else + else do when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err) + pure Nothing where diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env diff --git a/GHC/Linker/MacOS.hs b/GHC/Linker/MacOS.hs --- a/GHC/Linker/MacOS.hs +++ b/GHC/Linker/MacOS.hs @@ -172,6 +172,6 @@ findLoadDLL (p:ps) errs = do { dll <- loadDLL interp (p fwk_file) ; case dll of - Nothing -> return Nothing - Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + Right _ -> return Nothing + Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) } diff --git a/GHC/Linker/Types.hs b/GHC/Linker/Types.hs --- a/GHC/Linker/Types.hs +++ b/GHC/Linker/Types.hs @@ -40,7 +40,8 @@ import GHC.Unit ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) -import GHCi.RemoteTypes ( ForeignHValue ) +import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) +import GHCi.Message ( LoadedDLL ) import GHC.Types.Var ( Id ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) @@ -75,6 +76,53 @@ The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. + +Note [Looking up symbols in the relevant objects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #23415, we determined that a lot of time (>10s, or even up to >35s!) was +being spent on dynamically loading symbols before actually interpreting code +when `:main` was run in GHCi. The root cause was that for each symbol we wanted +to lookup, we would traverse the list of loaded objects and try find the symbol +in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in +the amount of loaded objects). + +To drastically improve load time (from +-38 seconds down to +-2s), we now: + +1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. + - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to + `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. + +2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in + the `pkgs_loaded` mapping, + +3. And only look for the symbol (with `dlsym`) on the /handles relevant to that + unit/, rather than in every loaded object. + +Note [Symbols may not be found in pkgs_loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently the `pkgs_loaded` mapping only contains the dynamic objects +associated with loaded units. Symbols defined in a static object (e.g. from a +statically-linked Haskell library) are found via the generic `lookupSymbol` +function call by `lookupHsSymbol` when the symbol is not found in any of the +dynamic objects of `pkgs_loaded`. + +The rationale here is two-fold: + + * we have only observed major link-time issues in dynamic linking; lookups in + the RTS linker's static symbol table seem to be fast enough + + * allowing symbol lookups restricted to a single ObjectCode would require the + maintenance of a symbol table per `ObjectCode`, which would introduce time and + space overhead + +This fallback is further needed because we don't look in the haskell objects +loaded for the home units (see the call to `loadModuleLinkables` in +`loadDependencies`, as opposed to the call to `loadPackages'` in the same +function which updates `pkgs_loaded`). We should ultimately keep track of the +objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit +unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) +and be able to lookup symbols specifically in them too (similarly to +`lookupSymbolInDLL`). -} newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } @@ -146,11 +194,13 @@ { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] + , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] + -- ^ See Note [Looking up symbols in the relevant objects] , loaded_pkg_trans_deps :: UniqDSet UnitId } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) = + ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = vcat [ppr uid , ppr hs_objs , ppr non_hs_objs @@ -159,10 +209,10 @@ -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { - linkableTime :: !UTCTime, -- ^ Time at which this linkable was built + linkableTime :: !UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) - linkableModule :: !Module, -- ^ The linkable module itself + linkableModule :: !Module, -- ^ The linkable module itself linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have yet to link. -- diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/HaddockLex.x" #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where @@ -352,7 +352,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 84 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 84 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -1215,7 +1215,7 @@ -- match when checking the right context, just -- the first match will do. #endif -{-# LINE 793 "_build/source-dist/ghc-9.10.1-src/ghc-9.10.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 793 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b diff --git a/GHC/Parser/PostProcess.hs b/GHC/Parser/PostProcess.hs --- a/GHC/Parser/PostProcess.hs +++ b/GHC/Parser/PostProcess.hs @@ -139,7 +139,6 @@ import GHC.Parser.Types import GHC.Parser.Lexer import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing import GHC.Core.Type ( Specificity(..) ) diff --git a/GHC/Platform.hs b/GHC/Platform.hs --- a/GHC/Platform.hs +++ b/GHC/Platform.hs @@ -79,7 +79,7 @@ , platformTablesNextToCode :: !Bool -- ^ Determines whether we will be compiling info tables that reside just -- before the entry code, or with an indirection to the entry code. See - -- TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h. + -- TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@. , platformHasLibm :: !Bool -- ^ Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/GHC/Rename/Env.hs @@ -1031,8 +1031,32 @@ -- lookupOccRnConstr looks up an occurrence of a RdrName and displays -- constructors and pattern synonyms as suggestions if it is not in scope +-- +-- There is a fallback to the type level, when the first lookup fails. +-- This is required to implement a pat-to-type transformation +-- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat) +-- Consider this example: +-- +-- data VisProxy a where VP :: forall a -> VisProxy a +-- +-- f :: VisProxy Int -> () +-- f (VP Int) = () +-- +-- Here `Int` is actually a type, but it stays on position where +-- we expect a data constructor. +-- +-- In all other cases we just use this additional lookup for better +-- error messaging (See Note [Promotion]). lookupOccRnConstr :: RdrName -> RnM Name -lookupOccRnConstr = lookupOccRn' WL_Constructor +lookupOccRnConstr rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> do + { mb_ty_gre <- lookup_promoted rdr_name + ; case mb_ty_gre of + Just gre -> return $ greName gre + Nothing -> reportUnboundName' WL_Constructor rdr_name} } -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- record fields as suggestions if it is not in scope diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs --- a/GHC/Rename/Module.hs +++ b/GHC/Rename/Module.hs @@ -1972,6 +1972,8 @@ is never used (invariant (I1)), so it barely makes sense to talk about the worker. A `type data` constructor only shows up in types, where it appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. + See #24620 for an example of what happens if you accidentally include + a wrapper. See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where this check is implemented. diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs --- a/GHC/Rename/Pat.hs +++ b/GHC/Rename/Pat.hs @@ -71,7 +71,6 @@ import GHC.Utils.Misc import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups ) -import GHC.Data.Bag ( Bag, unitBag, unionBags, emptyBag, listToBag, bagToList ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc @@ -89,7 +88,6 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio -import qualified Data.Semigroup as S import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Class import Control.Monad.Trans.Reader @@ -1242,43 +1240,6 @@ name <- lookupTypeOccRn rdr_name pure (name, unitFV name) --- | A variant of HsTyPatRn that uses Bags for efficient concatenation. --- See Note [Implicit and explicit type variable binders] -data HsTyPatRnBuilder = - HsTPRnB { - hstpb_nwcs :: Bag Name, - hstpb_imp_tvs :: Bag Name, - hstpb_exp_tvs :: Bag Name - } - -tpb_exp_tv :: Name -> HsTyPatRnBuilder -tpb_exp_tv name = mempty {hstpb_exp_tvs = unitBag name} - -tpb_hsps :: HsPSRn -> HsTyPatRnBuilder -tpb_hsps 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 - } - rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) rn_lty_pat (L l hs_ty) = do hs_ty' <- rn_ty_pat hs_ty @@ -1292,7 +1253,7 @@ then do -- binder name <- liftTPRnCps $ newPatName (LamMk True) lrdr - tellTPB (tpb_exp_tv name) + tellTPB (tpBuilderExplicitTV name) pure (L l name) else do -- usage @@ -1413,7 +1374,7 @@ ~(HsPS hsps ki') <- liftRnWithCont $ rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki) ty' <- rn_lty_pat ty - tellTPB (tpb_hsps hsps) + tellTPB (tpBuilderPatSig hsps) pure (HsKindSig an ty' ki') rn_ty_pat (HsSpliceTy _ splice) = do diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs --- a/GHC/Runtime/Eval.hs +++ b/GHC/Runtime/Eval.hs @@ -107,7 +107,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing -import GHC.Types.BreakInfo +import GHC.Types.Breakpoint import GHC.Types.Unique.Map import GHC.Unit @@ -143,29 +143,27 @@ getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) +mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History +mkHistory hsc_env hval ibi = History hval ibi (findEnclosingDecls hsc_env ibi) getHistoryModule :: History -> Module -getHistoryModule = breakInfo_module . historyBreakInfo +getHistoryModule = ibi_tick_mod . historyBreakpointId getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env History{..} = - let BreakInfo{..} = historyBreakInfo in - case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number +getHistorySpan hsc_env hist = + let ibi = historyBreakpointId hist in + case lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) of + Just hmi -> modBreaks_locs (getModBreaks hmi) ! ibi_tick_index ibi _ -> panic "getHistorySpan" {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env (BreakInfo modl ix) = - let hmi = expectJust "findEnclosingDecls" $ - lookupHugByModule modl (hsc_HUG hsc_env) - mb = getModBreaks hmi - in modBreaks_decls mb ! ix +findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String] +findEnclosingDecls hsc_env ibi = + let hmi = expectJust "findEnclosingDecls" $ lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) + in modBreaks_decls (getModBreaks hmi) ! ibi_tick_index ibi -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m () @@ -324,27 +322,24 @@ | otherwise = not_tracing where tracing - | EvalBreak apStack_ref maybe_break resume_ctxt _ccs <- status - , Just (EvalBreakpoint ix mod_name) <- maybe_break + | EvalBreak apStack_ref (Just eval_break) resume_ctxt _ccs <- status = do hsc_env <- getSession let interp = hscInterp hsc_env let dflags = hsc_dflags hsc_env - let hmi = expectJust "handleRunStatus" $ - lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) - modl = mi_module (hm_iface hmi) + let ibi = evalBreakpointToId (hsc_HPT hsc_env) eval_break + let hmi = expectJust "handleRunStatus" $ lookupHpt (hsc_HPT hsc_env) (moduleName (ibi_tick_mod ibi)) breaks = getModBreaks hmi b <- liftIO $ - breakpointStatus interp (modBreaks_flags breaks) ix + breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi) if b then not_tracing -- This breakpoint is explicitly enabled; we want to stop -- instead of just logging it. else do apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref - let bi = BreakInfo modl ix - !history' = mkHistory hsc_env apStack_fhv bi `consBL` history + let !history' = mkHistory hsc_env apStack_fhv ibi `consBL` history -- history is strict, otherwise our BoundedList is pointless. fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt let eval_opts = initEvalOpts dflags True @@ -362,23 +357,27 @@ let interp = hscInterp hsc_env resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref - let bp = evalBreakInfo (hsc_HPT hsc_env) <$> maybe_break + let ibi = evalBreakpointToId (hsc_HPT hsc_env) <$> maybe_break (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv bp + bindLocalsAtBreakpoint hsc_env apStack_fhv ibi let resume = Resume - { resumeStmt = expr, resumeContext = resume_ctxt_fhv - , resumeBindings = bindings, resumeFinalIds = final_ids + { resumeStmt = expr + , resumeContext = resume_ctxt_fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids , resumeApStack = apStack_fhv - , resumeBreakInfo = bp - , resumeSpan = span, resumeHistory = toListBL history + , resumeBreakpointId = ibi + , resumeSpan = span + , resumeHistory = toListBL history , resumeDecl = decl , resumeCCS = ccs - , resumeHistoryIx = 0 } + , resumeHistoryIx = 0 + } hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak names bp) + return (ExecBreak names ibi) -- Completed successfully | EvalComplete allocs (EvalSuccess hvals) <- status @@ -428,16 +427,21 @@ liftIO $ Loader.deleteFromLoadedEnv interp new_names case r of - Resume { resumeStmt = expr, resumeContext = fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_brkpt + Resume { resumeStmt = expr + , resumeContext = fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack + , resumeBreakpointId = mb_brkpt , resumeSpan = span , resumeHistory = hist } -> withVirtualCWD $ do - when (isJust mb_brkpt && isJust mbCnt) $ do - setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt) - -- When the user specified a break ignore count, set it - -- in the interpreter + -- When the user specified a break ignore count, set it + -- in the interpreter + case (mb_brkpt, mbCnt) of + (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt + _ -> return () + let eval_opts = initEvalOpts dflags (isStep step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist @@ -449,16 +453,15 @@ fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m () -- #19157 -setupBreakpoint hsc_env brkInfo cnt = do - let modl :: Module = breakInfo_module brkInfo +setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157 +setupBreakpoint hsc_env bi cnt = do + let modl = bi_tick_mod bi breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName modl) - ix = breakInfo_number brkInfo modBreaks = breaks hsc_env modl breakarray = modBreaks_flags modBreaks interp = hscInterp hsc_env - _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt + _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt pure () back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) @@ -501,11 +504,11 @@ if new_ix == 0 then case r of Resume { resumeApStack = apStack, - resumeBreakInfo = mb_brkpt } -> + resumeBreakpointId = mb_brkpt } -> update_ic apStack mb_brkpt else case history !! (new_ix - 1) of History{..} -> - update_ic historyApStack (Just historyBreakInfo) + update_ic historyApStack (Just historyBreakpointId) -- ----------------------------------------------------------------------------- @@ -517,7 +520,7 @@ bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue - -> Maybe BreakInfo + -> Maybe InternalBreakpointId -> IO (HscEnv, [Name], SrcSpan, String) -- Nothing case: we stopped when an exception was raised, not at a @@ -543,25 +546,28 @@ -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do +bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do let - hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) interp = hscInterp hsc_env - breaks = getModBreaks hmi - info = expectJust "bindLocalsAtBreakpoint2" $ - IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - occs = modBreaks_vars breaks ! breakInfo_number - span = modBreaks_locs breaks ! breakInfo_number - decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number + info_mod = ibi_info_mod ibi + info_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName info_mod) + info_brks = getModBreaks info_hmi + info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks) + + tick_mod = ibi_tick_mod ibi + tick_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod) + tick_brks = getModBreaks tick_hmi + occs = modBreaks_vars tick_brks ! ibi_tick_index ibi + span = modBreaks_locs tick_brks ! ibi_tick_index ibi + decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi + -- Rehydrate to understand the breakpoint info relative to the current environment. -- This design is critical to preventing leaks (#22530) (mbVars, result_ty) <- initIfaceLoad hsc_env - $ initIfaceLcl breakInfo_module (text "debugger") NotBoot + $ initIfaceLcl info_mod (text "debugger") NotBoot $ hydrateCgBreakInfo info - let -- Filter out any unboxed ids by changing them to Nothings; @@ -614,8 +620,10 @@ -- saved/restored, but not the linker state. See #1743, test break026. mkNewId :: OccName -> Type -> Id -> IO Id mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } + = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id) + -- NB: use variable namespace. + -- Don't use record field namespaces, lest we cause #25109. + ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) } newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types diff --git a/GHC/Runtime/Eval/Types.hs b/GHC/Runtime/Eval/Types.hs --- a/GHC/Runtime/Eval/Types.hs +++ b/GHC/Runtime/Eval/Types.hs @@ -19,7 +19,7 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing -import GHC.Types.BreakInfo +import GHC.Types.Breakpoint import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception @@ -50,8 +50,8 @@ , execAllocation :: Word64 } | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo + { breakNames :: [Name] + , breakPointId :: Maybe InternalBreakpointId } -- | Essentially a GlobalRdrEnv, but with additional cached values to allow @@ -73,11 +73,10 @@ , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) + , resumeBreakpointId :: Maybe InternalBreakpointId + -- ^ the breakpoint we stopped at -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, -- otherwise it's a pain to -- fetch the ModDetails & @@ -90,9 +89,8 @@ type ResumeBindings = ([TyThing], IcGlobalRdrEnv) -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } +data History = History + { historyApStack :: ForeignHValue + , historyBreakpointId :: InternalBreakpointId -- ^ breakpoint identifier + , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint + } diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs --- a/GHC/Runtime/Interpreter.hs +++ b/GHC/Runtime/Interpreter.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} -- | Interacting with the iserv interpreter, whether it is running on an @@ -28,13 +27,14 @@ , getClosure , getModBreaks , seqHValue - , evalBreakInfo + , evalBreakpointToId , interpreterDynamic , interpreterProfiled -- * The object-code linker , initObjLinker , lookupSymbol + , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive @@ -73,7 +73,7 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) -import GHC.Types.BreakInfo (BreakInfo(..)) +import GHC.Types.Breakpoint import GHC.ByteCode.Types import GHC.Linker.Types @@ -151,22 +151,22 @@ - implementation of Template Haskell (GHCi.TH) - a few other things needed to run interpreted code -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality +- top-level iserv directory, containing the code for the external + server. This is a fairly simple wrapper, most of the functionality is provided by modules in libraries/ghci. - This module which provides the interface to the server used by the rest of GHC. -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, interpreted code is run in the same process as GHC. Things that do not work with -fexternal-interpreter ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error +unknown type in the remote process. This API fails with an error message if it is used with -fexternal-interpreter. Other Notes on Remote GHCi @@ -394,14 +394,15 @@ status <- interpCmd interp (Seq hval) handleSeqHValueStatus interp unit_env status -evalBreakInfo :: HomePackageTable -> EvalBreakpoint -> BreakInfo -evalBreakInfo hpt (EvalBreakpoint ix mod_name) = - BreakInfo modl ix - where - modl = mi_module $ - hm_iface $ - expectJust "evalBreakInfo" $ - lookupHpt hpt (mkModuleName mod_name) +evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId +evalBreakpointToId hpt eval_break = + let load_mod x = mi_module $ hm_iface $ expectJust "evalBreakpointToId" $ lookupHpt hpt (mkModuleName x) + in InternalBreakpointId + { ibi_tick_mod = load_mod (eb_tick_mod eval_break) + , ibi_tick_index = eb_tick_index eval_break + , ibi_info_mod = load_mod (eb_info_mod eval_break) + , ibi_info_index = eb_info_index eval_break + } -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) @@ -411,7 +412,7 @@ -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - let bp = evalBreakInfo (ue_hpt unit_env) <$> maybe_break + let bp = evalBreakpointToId (ue_hpt unit_env) <$> maybe_break sdocBpLoc = brackets . ppr . getSeqBpSpan putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe $ sdocBpLoc bp)) @@ -421,14 +422,15 @@ handleSeqHValueStatus interp unit_env status (EvalComplete _ r) -> return r where - getSeqBpSpan :: Maybe BreakInfo -> SrcSpan - -- Just case: Stopped at a breakpoint, extract SrcSpan information - -- from the breakpoint. - getSeqBpSpan (Just BreakInfo{..}) = - (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number - -- Nothing case - should not occur! - -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq - getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "") + getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan + getSeqBpSpan = \case + Just bi -> (modBreaks_locs (breaks (ibi_tick_mod bi))) ! ibi_tick_index bi + -- Just case: Stopped at a breakpoint, extract SrcSpan information + -- from the breakpoint. + Nothing -> mkGeneralSrcSpan (fsLit "") + -- Nothing case - should not occur! + -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq + -- breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ lookupHpt (ue_hpt unit_env) (moduleName mod) @@ -440,57 +442,78 @@ initObjLinker interp = interpCmd interp InitLinker lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ())) -lookupSymbol interp str = case interpInstance interp of +lookupSymbol interp str = withSymbolCache interp str $ + case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #endif - - ExternalInterp ext -> case ext of - ExtIServ i -> withIServ i $ \inst -> do - -- Profiling of GHCi showed a lot of time and allocation spent - -- making cross-process LookupSymbol calls, so I added a GHC-side - -- cache which sped things up quite a lot. We have to be careful - -- to purge this cache when unloading code though. - cache <- readMVar (instLookupSymbolCache inst) - case lookupUFM cache str of - Just p -> return (Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS str)) - case m of - Nothing -> return Nothing - Just r -> do - let p = fromRemotePtr r - cache' = addToUFM cache str p - modifyMVar_ (instLookupSymbolCache inst) (const (pure cache')) - return (Just p) + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS str)) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) - ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) +lookupSymbolInDLL interp dll str = withSymbolCache interp str $ + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str)) +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbolInDLL dll (unpackFS str)) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) lookupClosure :: Interp -> String -> IO (Maybe HValueRef) lookupClosure interp str = interpCmd interp (LookupClosure str) +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' +-- which maps symbols to the address where they are loaded. +-- When there's a cache hit we simply return the cached address, when there is +-- a miss we run the action which determines the symbol's address and populate +-- the cache with the answer. +withSymbolCache :: Interp + -> FastString + -- ^ The symbol we are looking up in the cache + -> IO (Maybe (Ptr ())) + -- ^ An action which determines the address of the symbol we + -- are looking up in the cache, which is run if there is a + -- cache miss. The result will be cached. + -> IO (Maybe (Ptr ())) +withSymbolCache interp str determine_addr = do + + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + -- + -- The analysis in #23415 further showed this cache should also benefit the + -- internal interpreter's loading times, and needn't be used by the external + -- interpreter only. + cache <- readMVar (interpLookupSymbolCache interp) + case lookupUFM cache str of + Just p -> return (Just p) + Nothing -> do + + maddr <- determine_addr + case maddr of + Nothing -> return Nothing + Just p -> do + let upd_cache cache' = addToUFM cache' str p + modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache) + return (Just p) + purgeLookupSymbolCache :: Interp -> IO () -purgeLookupSymbolCache interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> pure () -#endif - ExternalInterp ext -> withExtInterpMaybe ext $ \case - Nothing -> pure () -- interpreter stopped, nothing to do - Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM)) +purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM)) -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either -- an absolute pathname to the file, or a relative filename -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL -- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: Interp -> String -> IO (Maybe String) +loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) loadDLL interp str = interpCmd interp (LoadDLL str) loadArchive :: Interp -> String -> IO () @@ -549,11 +572,9 @@ } pending_frees <- newMVar [] - lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = process , instPendingFrees = pending_frees - , instLookupSymbolCache = lookup_cache , instExtra = () } pure inst diff --git a/GHC/Runtime/Interpreter/JS.hs b/GHC/Runtime/Interpreter/JS.hs --- a/GHC/Runtime/Interpreter/JS.hs +++ b/GHC/Runtime/Interpreter/JS.hs @@ -41,7 +41,6 @@ import GHC.Utils.Error (logInfo) import GHC.Utils.Outputable (text) import GHC.Data.FastString -import GHC.Types.Unique.FM import Control.Concurrent import Control.Monad @@ -178,11 +177,9 @@ } pending_frees <- newMVar [] - lookup_cache <- newMVar emptyUFM let inst = ExtInterpInstance { instProcess = proc , instPendingFrees = pending_frees - , instLookupSymbolCache = lookup_cache , instExtra = extra } diff --git a/GHC/Runtime/Interpreter/Types.hs b/GHC/Runtime/Interpreter/Types.hs --- a/GHC/Runtime/Interpreter/Types.hs +++ b/GHC/Runtime/Interpreter/Types.hs @@ -51,6 +51,9 @@ , interpLoader :: !Loader -- ^ Interpreter loader + + , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) + -- ^ LookupSymbol cache } data InterpInstance @@ -107,9 +110,6 @@ -- ^ Values that need to be freed before the next command is sent. -- Finalizers for ForeignRefs can append values to this list -- asynchronously. - - , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) - -- ^ LookupSymbol cache , instExtra :: !c -- ^ Instance specific extra fields diff --git a/GHC/Settings.hs b/GHC/Settings.hs --- a/GHC/Settings.hs +++ b/GHC/Settings.hs @@ -26,6 +26,8 @@ , sArSupportsDashL , sPgm_L , sPgm_P + , sPgm_JSP + , sPgm_CmmP , sPgm_F , sPgm_c , sPgm_cxx @@ -45,6 +47,10 @@ , sOpt_L , sOpt_P , sOpt_P_fingerprint + , sOpt_JSP + , sOpt_JSP_fingerprint + , sOpt_CmmP + , sOpt_CmmP_fingerprint , sOpt_F , sOpt_c , sOpt_cxx @@ -92,11 +98,16 @@ , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool , toolSettings_arSupportsDashL :: Bool + , toolSettings_cmmCppSupportsG0 :: Bool -- commands for particular phases , toolSettings_pgm_L :: String , -- | The Haskell C preprocessor and default options (not added by -optP) toolSettings_pgm_P :: (String, [Option]) + , -- | The JavaScript C preprocessor and default options (not added by -optP) + toolSettings_pgm_JSP :: (String, [Option]) + , -- | The C-- C Preprocessor and default options (not added by -optP) + toolSettings_pgm_CmmP :: (String, [Option]) , toolSettings_pgm_F :: String , toolSettings_pgm_c :: String , toolSettings_pgm_cxx :: String @@ -124,9 +135,17 @@ -- options for particular phases , toolSettings_opt_L :: [String] , toolSettings_opt_P :: [String] + , toolSettings_opt_JSP :: [String] + , toolSettings_opt_CmmP :: [String] , -- | cached Fingerprint of sOpt_P -- See Note [Repeated -optP hashing] - toolSettings_opt_P_fingerprint :: Fingerprint + toolSettings_opt_P_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_JSP + -- See Note [Repeated -optP hashing] + toolSettings_opt_JSP_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_CmmP + -- See Note [Repeated -optP hashing] + toolSettings_opt_CmmP_fingerprint :: Fingerprint , toolSettings_opt_F :: [String] , toolSettings_opt_c :: [String] , toolSettings_opt_cxx :: [String] @@ -205,6 +224,10 @@ sPgm_L = toolSettings_pgm_L . sToolSettings sPgm_P :: Settings -> (String, [Option]) sPgm_P = toolSettings_pgm_P . sToolSettings +sPgm_JSP :: Settings -> (String, [Option]) +sPgm_JSP = toolSettings_pgm_JSP . sToolSettings +sPgm_CmmP :: Settings -> (String, [Option]) +sPgm_CmmP = toolSettings_pgm_CmmP . sToolSettings sPgm_F :: Settings -> String sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String @@ -243,6 +266,14 @@ sOpt_P = toolSettings_opt_P . sToolSettings sOpt_P_fingerprint :: Settings -> Fingerprint sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings +sOpt_JSP :: Settings -> [String] +sOpt_JSP = toolSettings_opt_JSP . sToolSettings +sOpt_JSP_fingerprint :: Settings -> Fingerprint +sOpt_JSP_fingerprint = toolSettings_opt_JSP_fingerprint . sToolSettings +sOpt_CmmP :: Settings -> [String] +sOpt_CmmP = toolSettings_opt_CmmP . sToolSettings +sOpt_CmmP_fingerprint :: Settings -> Fingerprint +sOpt_CmmP_fingerprint = toolSettings_opt_CmmP_fingerprint . sToolSettings sOpt_F :: Settings -> [String] sOpt_F = toolSettings_opt_F . sToolSettings sOpt_c :: Settings -> [String] diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs --- a/GHC/Settings/IO.hs +++ b/GHC/Settings/IO.hs @@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic +import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map @@ -72,29 +74,40 @@ -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $ - getRawFilePathSetting top_dir settingsFile mySettings key + -- Escape the 'top_dir', to make sure we don't accidentally introduce an + -- unescaped space + getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String - getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key + -- Escape the 'mtool_dir', to make sure we don't accidentally introduce + -- an unescaped space + getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key targetPlatformString <- getSetting "target platform string" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command" cc_args_str <- getToolSetting "C compiler flags" cxx_args_str <- getToolSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" cpp_prog <- getToolSetting "CPP command" cpp_args_str <- getToolSetting "CPP flags" hs_cpp_prog <- getToolSetting "Haskell CPP command" hs_cpp_args_str <- getToolSetting "Haskell CPP flags" + js_cpp_prog <- getToolSetting "JavaScript CPP command" + js_cpp_args_str <- getToolSetting "JavaScript CPP flags" + cmmCpp_prog <- getToolSetting "C-- CPP command" + cmmCpp_args_str <- getToolSetting "C-- CPP flags" platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] - cpp_args = map Option (words cpp_args_str) - hs_cpp_args = map Option (words hs_cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str + cpp_args = map Option (unescapeArgs cpp_args_str) + hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str) + js_cpp_args = map Option (unescapeArgs js_cpp_args_str) + cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str) + cc_args = unescapeArgs cc_args_str ++ unreg_cc_args + cxx_args = unescapeArgs cxx_args_str -- The extra flags we need to pass gcc when we invoke it to compile .hc code. -- @@ -135,12 +148,12 @@ let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) + ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) + | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) llvmTarget <- getSetting "LLVM target" @@ -177,9 +190,12 @@ , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW , toolSettings_arSupportsDashL = arSupportsDashL + , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 , toolSettings_pgm_L = unlit_path , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args) + , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args) + , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) , toolSettings_pgm_F = "" , toolSettings_pgm_c = cc_prog , toolSettings_pgm_cxx = cxx_prog @@ -198,7 +214,11 @@ , toolSettings_pgm_i = iserv_prog , toolSettings_opt_L = [] , toolSettings_opt_P = [] - , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_JSP = [] + , toolSettings_opt_CmmP = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_JSP_fingerprint = fingerprint0 + , toolSettings_opt_CmmP_fingerprint = fingerprint0 , toolSettings_opt_F = [] , toolSettings_opt_c = cc_args , toolSettings_opt_cxx = cxx_args @@ -261,3 +281,19 @@ , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -383,27 +383,40 @@ -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs mod) rhs) = do +schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule - current_mod_breaks <- getCurrentModBreaks - case break_info hsc_env mod current_mod current_mod_breaks of + mb_current_mod_breaks <- getCurrentModBreaks + case mb_current_mod_breaks of + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. Nothing -> pure code - Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = mod_ptr, modBreaks_ccs = cc_arr} -> do - platform <- profilePlatform <$> getProfile - let idOffSets = getVarOffSets platform d p fvs - ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) - toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) - breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty - newBreakInfo tick_no breakInfo - let cc | Just interp <- hsc_interp hsc_env - , interpreterProfiled interp - = cc_arr ! tick_no - | otherwise = toRemotePtr nullPtr - breakInstr = BRK_FUN breaks (fromIntegral tick_no) mod_ptr cc - return $ breakInstr `consOL` code + Just current_mod_breaks -> case break_info hsc_env tick_mod current_mod mb_current_mod_breaks of + Nothing -> pure code + Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do + platform <- profilePlatform <$> getProfile + let idOffSets = getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty + + let info_mod_ptr = modBreaks_module current_mod_breaks + infox <- newBreakInfo breakInfo + + let cc | Just interp <- hsc_interp hsc_env + , interpreterProfiled interp + = cc_arr ! tick_no + | otherwise = toRemotePtr nullPtr + + let -- cast that checks that round-tripping through Word16 doesn't change the value + toW16 x = let r = fromIntegral x :: Word16 + in if fromIntegral r == x + then r + else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x) + breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc + return $ breakInstr `consOL` code schemeER_wrk d p rhs = schemeE d 0 p rhs -- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module @@ -515,7 +528,7 @@ PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE return ( mkSlideB platform szb (d - s) -- clear to sequel - `consOL` ret) -- go + `appOL` ret) -- go -- construct and return an unboxed tuple returnUnboxedTuple @@ -783,7 +796,7 @@ platform <- profilePlatform <$> getProfile assert (sz == wordSize platform) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) - return (push_fn `appOL` (slide `consOL` unitOL ENTER)) + return (push_fn `appOL` (slide `appOL` unitOL ENTER)) do_pushes !d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps (these_args, rest_of_args) = splitAt n args @@ -1405,7 +1418,7 @@ (push_target `consOL` push_info `consOL` PUSH_BCO args_bco `consOL` - (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL)) + (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) -- ----------------------------------------------------------------------------- -- Deal with a CCall. @@ -2150,8 +2163,8 @@ ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr -mkSlideB platform nb db = SLIDE n d +mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr +mkSlideB platform nb db = mkSlideW n d where !n = bytesToWords platform nb !d = bytesToWords platform db @@ -2188,7 +2201,12 @@ , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints - , breakInfo :: IntMap CgBreakInfo + + , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. + -- Indexed with breakpoint *info* index. + -- See Note [Breakpoint identifiers] + -- in GHC.Types.Breakpoint + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) @@ -2202,7 +2220,7 @@ -> BcM r -> IO (BcM_State, r) runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty) + = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -2258,9 +2276,14 @@ = BcM $ \st -> let ctr = nextlabel st in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) -newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () -newBreakInfo ix info = BcM $ \st -> - return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) +newBreakInfo :: CgBreakInfo -> BcM Int +newBreakInfo info = BcM $ \st -> + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + in return (st', ix) getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st) diff --git a/GHC/StgToCmm/Config.hs b/GHC/StgToCmm/Config.hs --- a/GHC/StgToCmm/Config.hs +++ b/GHC/StgToCmm/Config.hs @@ -70,8 +70,11 @@ , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction + , stgToCmmAllowWordMul2Instr :: !Bool -- ^ Allowed to generate WordMul2 instruction , stgToCmmAllowFMAInstr :: FMASign -> Bool -- ^ Allowed to generate FMA instruction , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. + , stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see + -- Note [Saving foreign call target to local] for details ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested -- during compilation. In essence, this means checking for @-fllvm@ which is diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/GHC/StgToCmm/Foreign.hs @@ -277,23 +277,83 @@ load_target_into_temp other_target@(PrimTarget _) = return other_target +-- Note [Saving foreign call target to local] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- What we want to do here is create a new temporary for the foreign -- call argument if it is not safe to use the expression directly, -- because the expression mentions caller-saves GlobalRegs (see -- Note [Register parameter passing]). -- -- However, we can't pattern-match on the expression here, because --- this is used in a loop by GHC.Cmm.Parser, and testing the expression --- results in a black hole. So we always create a temporary, and rely --- on GHC.Cmm.Sink to clean it up later. (Yuck, ToDo). The generated code --- ends up being the same, at least for the RTS .cmm code. +-- this is used in a loop by GHC.Cmm.Parser, and testing the +-- expression results in a black hole. So when there exist +-- caller-saves GlobalRegs, we create a temporary, and rely on +-- GHC.Cmm.Sink to clean it up later. The generated code ends up being +-- the same if -fcmm-sink is enabled (implied by -O). -- +-- When there doesn't exist caller-save GlobalRegs, keep the original +-- target in place. This matters for the wasm backend, otherwise it +-- cannot infer the target symbol's correct foreign function type in +-- unoptimized Cmm. For instance: +-- +-- foreign import ccall unsafe "foo" c_foo :: IO () +-- +-- Without optimization, previously this would lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDk: +-- goto cDm; +-- cDm: +-- _cDj::I32 = foo; +-- call "ccall" arg hints: [] result hints: [] (_cDj::I32)(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- The wasm backend only sees "foo" being assigned to a local, but +-- there's no type signature associated with a CLabel! So it has to +-- emit a dummy .functype directive and fingers crossed that wasm-ld +-- tolerates function type mismatch. THis is horrible, not future +-- proof against upstream toolchain upgrades, and already known to +-- break in certain cases (e.g. when LTO objects are involved). +-- +-- Therefore, on wasm as well as other targets that don't risk +-- mentioning caller-saved GlobalRegs in a foreign call target, just +-- keep the original call target in place and don't assign it to a +-- local. So this would now lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDo: +-- goto cDq; +-- cDq: +-- call "ccall" arg hints: [] result hints: [] foo(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- Since "foo" appears at call site directly, the wasm backend would +-- now be able to infer its type signature correctly. + maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e = do - platform <- getPlatform - reg <- newTemp (cmmExprType platform e) - emitAssign (CmmLocal reg) e - return (CmmReg (CmmLocal reg)) + do_save <- stgToCmmSaveFCallTargetToLocal <$> getStgToCmmConfig + if do_save + then do + platform <- getPlatform + reg <- newTemp (cmmExprType platform e) + emitAssign (CmmLocal reg) e + return (CmmReg (CmmLocal reg)) + else + pure e -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO diff --git a/GHC/StgToCmm/InfoTableProv.hs b/GHC/StgToCmm/InfoTableProv.hs --- a/GHC/StgToCmm/InfoTableProv.hs +++ b/GHC/StgToCmm/InfoTableProv.hs @@ -178,7 +178,7 @@ to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] to_ipe_buf_ent cg_ipe = [ ipeTableName cg_ipe - , ipeClosureDesc cg_ipe + , fromIntegral $ ipeClosureDesc cg_ipe , ipeTypeDesc cg_ipe , ipeLabel cg_ipe , ipeSrcFile cg_ipe @@ -193,7 +193,6 @@ toCgIPE :: Platform -> SDocContext -> InfoProvEnt -> State StringTable CgInfoProvEnt toCgIPE platform ctx ipe = do table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe)) - closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe) type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) let (src_loc_file, src_loc_span) = @@ -208,7 +207,7 @@ src_span <- lookupStringTable $ ST.pack src_loc_span return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe , ipeTableName = table_name - , ipeClosureDesc = closure_desc + , ipeClosureDesc = fromIntegral (infoProvEntClosureType ipe) , ipeTypeDesc = type_desc , ipeLabel = label , ipeSrcFile = src_file @@ -218,7 +217,7 @@ data CgInfoProvEnt = CgInfoProvEnt { ipeInfoTablePtr :: !CLabel , ipeTableName :: !StrTabOffset - , ipeClosureDesc :: !StrTabOffset + , ipeClosureDesc :: !Word32 , ipeTypeDesc :: !StrTabOffset , ipeLabel :: !StrTabOffset , ipeSrcFile :: !StrTabOffset diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -1623,7 +1623,7 @@ else Right genericIntSubCOp WordMul2Op -> \args -> opCallishHandledLater args $ - if allowExtAdd + if allowWord2Mul then Left (MO_U_Mul2 (wordWidth platform)) else Right genericWordMul2Op @@ -1850,6 +1850,7 @@ allowQuotRem2 = stgToCmmAllowQuotRem2 cfg allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg allowInt2Mul = stgToCmmAllowIntMul2Instr cfg + allowWord2Mul = stgToCmmAllowWordMul2Instr cfg allowFMA = stgToCmmAllowFMAInstr cfg @@ -2180,8 +2181,8 @@ -> CmmType -- ^ index type -> AlignmentSpec alignmentFromTypes ty idx_ty - | typeWidth ty < typeWidth idx_ty = NaturallyAligned - | otherwise = Unaligned + | typeWidth ty <= typeWidth idx_ty = NaturallyAligned + | otherwise = Unaligned doIndexOffAddrOp :: Maybe MachOp -> CmmType diff --git a/GHC/StgToJS/Linker/Linker.hs b/GHC/StgToJS/Linker/Linker.hs --- a/GHC/StgToJS/Linker/Linker.hs +++ b/GHC/StgToJS/Linker/Linker.hs @@ -284,10 +284,31 @@ hPutChar h '\n' let emcc_opts' = emcc_opts <> opts go_entries emcc_opts' cc_objs es - Nothing -> do - logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text (Ar.filename e)]) - go_entries emcc_opts cc_objs es + Nothing -> case Ar.filename e of + -- JavaScript code linker does not support symbol table processing. + -- Currently the linker does nothing when the symbol table is met. + -- Ar/Ranlib usually do not create a record for the symbol table + -- in the object archive when the table has no entries. + -- For JavaScript code it should not be created by default. + "__.SYMDEF" -> + -- GNU Ar added the symbol table. + + -- Emscripten Ar (at least 3.1.24 version) + -- adds it even when the symbol table is empty. + go_entries emcc_opts cc_objs es + "__.SYMDEF SORTED" -> + -- BSD-like Ar added the symbol table. + + -- By default, Clang Ar does not add it when the + -- symbol table is empty (and it should be empty) but we left + -- it here to handle the case with symbol table completely + -- for GNU and BSD tools. + go_entries emcc_opts cc_objs es + unknown_name -> do + logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text unknown_name]) + go_entries emcc_opts cc_objs es + -- additional JS objects (e.g. from the command-line) go_extra emcc_opts = \case [] -> pure emcc_opts @@ -728,12 +749,64 @@ rtsExterns :: FastString rtsExterns = + -- Google Closure Compiler --externs option is deprecated. + -- Need pass them as a js file with @externs module-level jsdoc. + "/** @externs @suppress {duplicate} */\n" <> "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> - mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") - [(7::Int)..16384]) + mconcat + -- See GHC.StgToJS + -- We connect all payload fields "dXX" on JavaScript Object. + -- That's most simple way to make Google Closure Compiler prevent + -- property names mangling. + (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") + [(1::Int)..16384]) <> + mconcat + (map (\x -> "/** @type {*} */\nObject." <> x <> ";\n") + -- We do same for special STG properties as well. + ["m", "f", "cc", "t", "size", "i", "n", "a", "r", "s"]) <> + mconcat + [ -- Used at h$mkForeignCallback + "/** @type {*} */\nObject.mv;\n" + ] <> + mconcat + (map (\x -> x <> ";\n") + [ -- Externs needed by node environment + "/** @type {string} */ var __dirname" + -- Copied minimally from https://github.com/externs/nodejs/blob/6c6882c73efcdceecf42e7ba11f1e3e5c9c041f0/v8/nodejs.js#L8 + , "/** @const */ var NodeJS = {}" + -- NodeJS Stream interface + , "/** @interface */ NodeJS.Stream = function () {}" + , "/** @template THIS @this {THIS} @return {THIS} */ NodeJS.Stream.prototype.on = function() {}" + , "/** @return {boolean} */ NodeJS.Stream.prototype.write = function() {}" + -- NodeJS versions property contains actual versions of the environment + , "/** @interface */ NodeJS.ProcessVersions = function() {}" + , "/** @type {string} */ NodeJS.ProcessVersions.prototype.node" + -- NodeJS Process interface + , "/** @interface */ NodeJS.Process = function() {}" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stderr" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdin" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdout" + , "/** @type {!NodeJS.ProcessVersions} */ NodeJS.Process.prototype.versions" + , "/** @return {?} */ NodeJS.Process.prototype.exit = function() {}" + , "/** @type {!Array} */ NodeJS.Process.prototype.argv" + -- NodeJS Process definition + , "/** @type {!NodeJS.Process} */ var process" + -- NodeJS Buffer class + , "/** @extends {Uint8Array} @constructor */ function Buffer(arg1, encoding) {}" + , "/** @return {!Buffer} */ Buffer.alloc = function() {}" + -- Emscripten Module + , "/** @type {*} */ var Module" + -- Mozilla's Narcissus (JS in JS interpreter implemented on top of SpiderMonkey) environment + , "/** @type {*} */ var putstr" + , "/** @type {*} */ var printErr" + -- Apples's JavaScriptCore environment + , "/** @type {*} */ var debug" + -- We use only Heap8 from Emscripten + , "/** @type {!Int8Array} */ Module.HEAP8" + ]) writeExterns :: FilePath -> IO () -writeExterns out = writeFile (out "all.js.externs") +writeExterns out = writeFile (out "all.externs.js") $ unpackFS rtsExterns -- | Get all block dependencies for a given set of roots @@ -1095,8 +1168,9 @@ js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" let cpp_opts = CppOpts - { useHsCpp = False - , cppLinePragmas = False -- LINE pragmas aren't JS compatible + { sourceCodePreprocessor = SCPJsCpp + -- JS code requires keeping JSDoc comments for third party minification tooling + , cppLinePragmas = False -- LINE pragmas aren't JS compatible } doCpp logger tmpfs diff --git a/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs --- a/GHC/StgToJS/Linker/Utils.hs +++ b/GHC/StgToJS/Linker/Utils.hs @@ -140,7 +140,7 @@ -- Put Addr# in ByteArray# or at Addr# (same thing) , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" - , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null); var ro = (a).dv.getInt32(o,true);\n" -- Data.Maybe.Maybe , "#define HS_NOTHING h$ghczminternalZCGHCziInternalziMaybeziNothing\n" diff --git a/GHC/StgToJS/Literal.hs b/GHC/StgToJS/Literal.hs --- a/GHC/StgToJS/Literal.hs +++ b/GHC/StgToJS/Literal.hs @@ -115,7 +115,24 @@ LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) , IntLit 0 ] - l -> pprPanic "genStaticLit" (ppr l) + LitRubbish _ rep -> + let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep + in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> pure [ NullLit ] + AddrRep -> pure [ NullLit, IntLit 0 ] + IntRep -> pure [ IntLit 0 ] + Int8Rep -> pure [ IntLit 0 ] + Int16Rep -> pure [ IntLit 0 ] + Int32Rep -> pure [ IntLit 0 ] + Int64Rep -> pure [ IntLit 0, IntLit 0 ] + WordRep -> pure [ IntLit 0 ] + Word8Rep -> pure [ IntLit 0 ] + Word16Rep -> pure [ IntLit 0 ] + Word32Rep -> pure [ IntLit 0 ] + Word64Rep -> pure [ IntLit 0, IntLit 0 ] + FloatRep -> pure [ DoubleLit (SaneDouble 0) ] + DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] + VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JStgExpr diff --git a/GHC/StgToJS/Prim.hs b/GHC/StgToJS/Prim.hs --- a/GHC/StgToJS/Prim.hs +++ b/GHC/StgToJS/Prim.hs @@ -940,7 +940,7 @@ ------------------------------- Delay/Wait Ops --------------------------------- DelayOp -> \[] [t] -> pure $ PRPrimCall $ returnS (app "h$delayThread" [t]) - WaitReadOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waidRead" [fd]) + WaitReadOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitRead" [fd]) WaitWriteOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitWrite" [fd]) ------------------------------- Concurrency Primitives ------------------------- diff --git a/GHC/StgToJS/Rts/Rts.hs b/GHC/StgToJS/Rts/Rts.hs --- a/GHC/StgToJS/Rts/Rts.hs +++ b/GHC/StgToJS/Rts/Rts.hs @@ -371,7 +371,8 @@ , global "h$ct_stackframe" ||= toJExpr StackFrame , global "h$vt_ptr" ||= toJExpr PtrV , global "h$vt_void" ||= toJExpr VoidV - , global "h$vt_double" ||= toJExpr IntV + , global "h$vt_int" ||= toJExpr IntV + , global "h$vt_double" ||= toJExpr DoubleV , global "h$vt_long" ||= toJExpr LongV , global "h$vt_addr" ||= toJExpr AddrV , global "h$vt_obj" ||= toJExpr ObjV @@ -669,6 +670,10 @@ , r1 |= x , returnS (stack .! sp) ]) + , closure (ClosureInfo (global "h$reportHeapOverflow") (CIRegs 0 [PtrV]) "h$reportHeapOverflow" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ (appS "throw" [jString "h$reportHeapOverflow: Heap Overflow!"])) + , closure (ClosureInfo (global "h$reportStackOverflow") (CIRegs 0 [PtrV]) "h$reportStackOverflow" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ (appS "throw" [jString "h$reportStackOverflow: Stack Overflow!"])) -- Top-level statements to generate only in profiling mode , fmap (profStat s) $ (closure (ClosureInfo (global "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) (return $ diff --git a/GHC/StgToJS/Types.hs b/GHC/StgToJS/Types.hs --- a/GHC/StgToJS/Types.hs +++ b/GHC/StgToJS/Types.hs @@ -26,7 +26,7 @@ import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.JS.Make -import GHC.JS.Ppr () +import GHC.JS.Ppr () -- expose Outputable instances to downstream modules import GHC.Stg.Syntax import GHC.Core.TyCon diff --git a/GHC/SysTools/Cpp.hs b/GHC/SysTools/Cpp.hs --- a/GHC/SysTools/Cpp.hs +++ b/GHC/SysTools/Cpp.hs @@ -40,34 +40,70 @@ import System.FilePath data CppOpts = CppOpts - { useHsCpp :: !Bool - -- ^ Use the Haskell C preprocessor, otherwise use the C preprocessor. - -- See the Note [Preprocessing invocations] - , cppLinePragmas :: !Bool + { sourceCodePreprocessor :: !SourceCodePreprocessor + , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas } {- Note [Preprocessing invocations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must consider two distinct preprocessors when preprocessing Haskell. +We must consider four distinct preprocessors when preprocessing Haskell. These are: (1) The Haskell C preprocessor (HsCpp), which preprocesses Haskell files that make use of the CPP language extension -(2) The C preprocessor (Cpp), which is used to preprocess C and Cmm files +(2) The C preprocessor (Cpp), which is used to preprocess C files +(3) The JavaScript preprocessor (JsCpp), which preprocesses JavaScript files + +(4) The C-- preprocessor (CmmCpp), which preprocesses C-- files + These preprocessors are indeed different. Despite often sharing the same underlying program (the C compiler), the set of flags passed determines the behaviour of the preprocessor, and Cpp and HsCpp behave differently. Specifically, we rely on "traditional" (pre-standard) preprocessing semantics (which most compilers expose via the `-traditional` flag) when preprocessing -Haskell source. This avoids, e.g., the preprocessor removing C-style comments. +Haskell source. This avoids the following situations: + + * Removal of C-style comments, which are not comments in Haskell but valid + operators; + + * Errors due to an ANSI C preprocessor lexing the source and failing on + names with single quotes (TH quotes, ticked promoted constructors, + names with primes in them). + + Both of those cases may be subtle: gcc and clang permit C++-style // + comments in C code, and Data.Array and Data.Vector both export a // + operator whose type is such that a removed "comment" may leave code that + typechecks but does the wrong thing. Another example is that, since ANSI + C permits long character constants, an expression involving multiple + functions with primes in their names may not expand macros properly when + they occur between the primed functions. + +Third special type of preprocessor for JavaScript was added laterly due to +needing to keep JSDoc comments and multiline comments. Various third party +minifying software (for example, Google Closure Compiler) uses JSDoc +information to apply more strict rules to code reduction which results in +better but more dangerous minification. JSDoc comments are usually used to +instruct minifiers where dangerous optimizations could be applied. + +The fourth, the C-- preprocessor, is needed as modern compilers emit defines +for debug info generation when preprocessing. The C-- preprocessor avoids this +by suppressing debug info generation. The C-- preprocessor also inherits flags +passed to the C compiler. This is done for compatibility. Following those, +the C-- compiler receives -g0, if it was detected as supported, and flags +passed via -optCmmP specifically for the C-- preprocessor. The combined +command line looks like: + + $pgmCmmP $optCs_without_g3s $g0_if_supported $optCmmP + -} --- | Run either the Haskell preprocessor or the C preprocessor, as per the --- 'CppOpts' passed. See Note [Preprocessing invocations]. +-- | Run either the Haskell preprocessor, JavaScript preprocessor +-- or the C preprocessor, as per the 'CppOpts' passed. +-- See Note [Preprocessing invocations]. -- -- UnitEnv is needed to compute MIN_VERSION macros doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO () @@ -95,9 +131,7 @@ let verbFlags = getVerbFlags dflags - let cpp_prog args - | useHsCpp opts = GHC.SysTools.runHsCpp logger dflags args - | otherwise = GHC.SysTools.runCpp logger tmpfs dflags args + let cpp_prog args = runSourceCodePreprocessor logger tmpfs dflags (sourceCodePreprocessor opts) args let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform @@ -225,11 +259,17 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) - return (( "ghcversion.h") <$> collectIncludeDirs ps) + let candidates = case ghcVersionFile dflags of + -- the user has provided an explicit `ghcversion.h` file to use. + Just path -> [path] + -- otherwise, try to find it in the rts' include-dirs. + -- Note: only in the RTS include-dirs! not all preload units less we may + -- use a wrong file. See #25106 where a globally installed + -- /usr/include/ghcversion.h file was used instead of the one provided + -- by the rts. + Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of + Nothing -> [] + Just info -> ( "ghcversion.h") <$> collectIncludeDirs [info] found <- filterM doesFileExist candidates case found of diff --git a/GHC/SysTools/Tasks.hs b/GHC/SysTools/Tasks.hs --- a/GHC/SysTools/Tasks.hs +++ b/GHC/SysTools/Tasks.hs @@ -107,32 +107,75 @@ | "warning: call-clobbered register used" `isContainedIn` w = False | otherwise = True --- | Run the C preprocessor, which is different from running the --- Haskell C preprocessor (they're configured separately!). --- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp -runCpp :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCpp logger tmpfs dflags args = traceSystoolCommand logger "cpp" $ do - let (p,args0) = pgm_cpp dflags - userOpts_c = map Option $ getOpts dflags opt_c - args2 = args0 ++ args ++ userOpts_c - mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter "C pre-processor" p - args2 mb_env +-- | See the Note [Preprocessing invocations] +data SourceCodePreprocessor + = SCPCpp + -- ^ Use the ordinary C preprocessor + | SCPHsCpp + -- ^ Use the Haskell C preprocessor (don't remove C comments, don't break on names including single quotes) + | SCPJsCpp + -- ^ Use the JavaScript preprocessor (don't remove jsdoc and multiline comments) + | SCPCmmCpp + -- ^ Use the C-- preprocessor (don't emit debug information) + deriving (Eq) --- | Run the Haskell C preprocessor. +-- | Run source code preprocessor. -- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp -runHsCpp :: Logger -> DynFlags -> [Option] -> IO () -runHsCpp logger dflags args = traceSystoolCommand logger "hs-cpp" $ do - let (p,args0) = pgm_P dflags - opts = getOpts dflags opt_P - modified_imports = augmentImports dflags opts - args1 = map Option modified_imports +runSourceCodePreprocessor + :: Logger + -> TmpFs + -> DynFlags + -> SourceCodePreprocessor + -> [Option] + -> IO () +runSourceCodePreprocessor logger tmpfs dflags preprocessor args = + traceSystoolCommand logger logger_name $ do + let + (p, args0) = pgm_getter dflags + args1 = Option <$> (augmentImports dflags $ getOpts dflags opt_getter) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 -- romes: what about args0 and args? - runSomethingFiltered logger id "Haskell C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) Nothing mb_env + all_args = args0 ++ args1 ++ args2 ++ args + mb_env <- getGccEnv (args0 ++ args1) + + runSomething readable_name p all_args mb_env + + where + toolSettings' = toolSettings dflags + cmmG0 = ["-g0" | toolSettings_cmmCppSupportsG0 toolSettings'] + -- GCC <=10 (pre commit r11-5596-g934a54180541d2) implied -dD for debug + -- flags by the spec snippet %{g3|ggdb3|gstabs3|gxcoff3|gvms3:-dD}. This + -- means that a g0 will not override a previously-specified -g3 causing + -- debug info emission (see https://gcc.gnu.org/PR97989). We're filtering + -- -optc here, rather than the combined command line, in order to avoid an + -- issue where a user has to, for some reason, override our decision. If + -- they see the need to do that, they can pass -optCmmP. + g3Flags = ["-g3", "-ggdb3", "-gstabs3", "-gxcoff3", "-gvms3"] + optCFiltered = filter (`notElem` g3Flags) . opt_c + -- In the wild (and GHC), there is lots of code assuming that -optc gets + -- passed to the C-- preprocessor too. Note that the arguments are + -- reversed by getOpts. + cAndCmmOpt dflags = opt_CmmP dflags ++ cmmG0 ++ optCFiltered dflags + (logger_name, pgm_getter, opt_getter, readable_name) + = case preprocessor of + SCPCpp -> ("cpp", pgm_cpp, opt_c, "C pre-processor") + SCPHsCpp -> ("hs-cpp", pgm_P, opt_P, "Haskell C pre-processor") + SCPJsCpp -> ("js-cpp", pgm_JSP, opt_JSP, "JavaScript C pre-processor") + SCPCmmCpp -> ("cmm-cpp", pgm_CmmP, cAndCmmOpt, "C-- C pre-processor") + + runSomethingResponseFileCpp + = runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter + runSomethingFilteredOther phase_name pgm args mb_env + = runSomethingFiltered logger id phase_name pgm args Nothing mb_env + + runSomething + = case preprocessor of + SCPCpp -> runSomethingResponseFileCpp + SCPHsCpp -> runSomethingFilteredOther + SCPJsCpp -> runSomethingFilteredOther + SCPCmmCpp -> runSomethingResponseFileCpp + runPp :: Logger -> DynFlags -> [Option] -> IO () runPp logger dflags args = traceSystoolCommand logger "pp" $ do let prog = pgm_F dflags @@ -243,14 +286,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 + LLVM version 15.0.7 ... + OR + LLVM (http://llvm.org/): + LLVM version 14.0.6 -} hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline + line1 <- hGetLine pout + mb_ver <- case parseLlvmVersion line1 of + mb_ver@(Just _) -> return mb_ver + Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs --- a/GHC/Tc/Errors.hs +++ b/GHC/Tc/Errors.hs @@ -465,6 +465,8 @@ flav = ctFlavour ct ; (suppress, m_evdest) <- case ctEvidence ct of + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint CtGiven {} -> return (False, Nothing) CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } -> do { rewriters' <- zonkRewriterSet rewriters @@ -2094,10 +2096,9 @@ case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> (TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 + { teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 , teq_mismatch_actual = uo_actual , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing @@ -2121,26 +2122,7 @@ where orig = errorItemOrigin item mb_same_occ = sameOccExtras ty2 ty1 - ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) --- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. --- --- 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. -shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool -shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_visible = vis }) - | not vis = True -- See tests T15870, T16204c - | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144. -shouldPprWithExplicitKinds ty1 ty2 _ct - = tcEqTypeVis ty1 ty2 - {- Note [Insoluble mis-match] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble @@ -2401,29 +2383,6 @@ Perhaps you meant ‘getAlt’ (imported from Data.Monoid) Perhaps you want to add ‘getAll’ to the import list in the import of ‘Data.Monoid’ --} - -{- -Note [Kind arguments 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, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -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`. -} ----------------------- diff --git a/GHC/Tc/Errors/Hole/Plugin.hs-boot b/GHC/Tc/Errors/Hole/Plugin.hs-boot --- a/GHC/Tc/Errors/Hole/Plugin.hs-boot +++ b/GHC/Tc/Errors/Hole/Plugin.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Errors.Hole.Plugin where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data HoleFitPlugin diff --git a/GHC/Tc/Errors/Ppr.hs b/GHC/Tc/Errors/Ppr.hs --- a/GHC/Tc/Errors/Ppr.hs +++ b/GHC/Tc/Errors/Ppr.hs @@ -54,8 +54,8 @@ import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) -import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) +import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon, + pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type @@ -536,7 +536,7 @@ , text "cannot be inferred from the right-hand side." ] in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) - in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $ + in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $ hang herald 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) TcRnBangOnUnliftedType ty @@ -1182,7 +1182,7 @@ ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) IsGADT -> (text "A newtype must not be a GADT", - ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec + ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec (ppr $ dataConDisplayType show_linear_types con)) HasConstructorContext -> (text "A newtype constructor must not have a context in its type", @@ -1432,7 +1432,7 @@ , text "Perhaps enable PolyKinds or add a kind signature" ]) TcRnUninferrableTyVar tidied_tvs context -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ text "Uninferrable type variable" <> plural tidied_tvs <+> pprWithCommas pprTyVar tidied_tvs @@ -1440,7 +1440,7 @@ , pprUninferrableTyVarCtx context ] TcRnSkolemEscape escapees tv orig_ty -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees , quotes $ pprTyVars escapees , text "would escape" <+> itsOrTheir escapees <+> text "scope" @@ -1884,7 +1884,7 @@ TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs -> mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ + pprWithInvisibleBitsWhen True $ vcat [ text "Invalid defaulting proposal." , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon) 2 (pprQuotedList (NE.toList bad_tvs)) @@ -4153,17 +4153,18 @@ | otherwise = text "kind" <+> quotes (ppr exp) pprMismatchMsg ctxt - (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item + (TypeEqMismatch { teq_mismatch_item = item , teq_mismatch_ty1 = ty1 -- These types are the actual types , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped , teq_mismatch_expected = exp -- These are the context of , teq_mismatch_actual = act -- the mis-match , teq_mismatch_what = mb_thing , teq_mb_same_occ = mb_same_occ }) - = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - $$ maybe empty pprSameOccInfo mb_same_occ + = addArising ct_loc $ + pprWithInvisibleBitsWhen ppr_invis_bits msg + $$ maybe empty pprSameOccInfo mb_same_occ where + msg | Just (torc, rep) <- sORTKind_maybe exp = msg_for_exp_sort torc rep @@ -4226,6 +4227,7 @@ ct_loc = errorItemCtLoc item orig = errorItemOrigin item level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig num_args_msg = case level of KindLevel @@ -4317,7 +4319,61 @@ _ -> pprTheta wanteds +-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. +-- See Note [Showing invisible bits of types in error messages] +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible +-- equality; if it's not, definitely print the kinds. Even if the equality is +-- a visible equality, check the expected/actual types to see if the types +-- have equal visible components. If the 'CtOrigin' is +-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. +shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool +shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_visible = vis }) + | not vis = True -- See tests T15870, T16204c + | otherwise = mayLookIdentical act exp -- See tests T9171, T9144. +shouldPprWithInvisibleBits ty1 ty2 _ct + = mayLookIdentical ty1 ty2 +{- Note [Showing invisible bits of types in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, when we find a type or kind mis-match: + +* See if normally-visible parts of the type would make the two types + look different. This check is made by + `GHC.Core.TyCo.Compare.mayLookIdentical` + +* If not, display the types with their normally-visible parts made visible, + by setting flags in the `SDocContext": + Specifically: + - Display kind arguments: sdocPrintExplicitKinds + - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps, + which controls `GHC.Iface.Type.hideNonStandardTypes` + (NB: foralls are always printed by pprType, it turns out.) + +As a result the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. + +Another example of what goes wrong without this: #24553. +-} + {- ********************************************************************* * * Displaying potential instances @@ -6040,7 +6096,7 @@ IllegalFamilyInstance reason -> pprIllegalFamilyInstance reason IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args -> - pprWithExplicitKindsWhen invis_arg $ + pprWithInvisibleBitsWhen invis_arg $ hang (text "Illegal type synonym family application" <+> quotes (ppr tf_ty) <+> text "in instance" <> colon) 2 (ppr inst_ty) @@ -6123,7 +6179,7 @@ , not_covered_invis_vis_tvs = undetermined_tvs , not_covered_liberal = which_cc_failed } = - pprWithExplicitKindsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ + pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ vcat [ sep [ text "The" <+> ppWhen liberal (text "liberal") <+> text "coverage condition fails in class" @@ -6385,7 +6441,7 @@ , text "mentions none of the type or kind variables of the class" <+> quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))] AssocTyVarsDontMatch vis fam_tc exp_tys act_tys -> - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ + pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $ vcat [ text "Type indexes must match class instance head" , text "Expected:" <+> pp exp_tys , text " Actual:" <+> pp act_tys ] @@ -6409,7 +6465,7 @@ let (pat_tv, pat_vis) = NE.head dups in (pat_vis, text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") - in pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ + in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $ hang main_msg 2 (vcat [ppr_eqn, suggestion]) where diff --git a/GHC/Tc/Errors/Types.hs b/GHC/Tc/Errors/Types.hs --- a/GHC/Tc/Errors/Types.hs +++ b/GHC/Tc/Errors/Types.hs @@ -5525,8 +5525,7 @@ -- -- Test cases: T1470, tcfail212. | TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_item :: ErrorItem + { teq_mismatch_item :: ErrorItem , teq_mismatch_ty1 :: Type , teq_mismatch_ty2 :: Type , teq_mismatch_expected :: Type -- ^ The overall expected type diff --git a/GHC/Tc/Gen/App.hs b/GHC/Tc/Gen/App.hs --- a/GHC/Tc/Gen/App.hs +++ b/GHC/Tc/Gen/App.hs @@ -56,7 +56,6 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) -import GHC.Types.SourceText import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable @@ -899,18 +898,12 @@ where unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e) - go (L l e@(HsOverLit _ lit)) = - do { tylit <- case ol_val lit of - HsIntegral n -> return $ HsNumTy NoSourceText (il_value n) - HsIsString _ s -> return $ HsStrTy NoSourceText s - HsFractional _ -> failWith $ TcRnIllformedTypeArgument (L l e) - ; return (L l (HsTyLit noExtField tylit)) } - go (L l e@(HsLit _ lit)) = - do { tylit <- case lit of - HsChar _ c -> return $ HsCharTy NoSourceText c - HsString _ s -> return $ HsStrTy NoSourceText s - _ -> failWith $ TcRnIllformedTypeArgument (L l e) - ; return (L l (HsTyLit noExtField tylit)) } + go (L l (HsOverLit _ lit)) + | Just tylit <- tyLitFromOverloadedLit (ol_val lit) + = return (L l (HsTyLit noExtField tylit)) + go (L l (HsLit _ lit)) + | Just tylit <- tyLitFromLit lit + = return (L l (HsTyLit noExtField tylit)) go (L l (ExplicitTuple _ tup_args boxity)) -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted | isBoxed boxity diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs --- a/GHC/Tc/Gen/Bind.hs +++ b/GHC/Tc/Gen/Bind.hs @@ -723,7 +723,6 @@ {- Note [Non-variable pattern bindings aren't linear] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - A fundamental limitation of the typechecking algorithm is that we cannot have a binding which, at the same time, - is linear in its rhs @@ -735,17 +734,35 @@ To address this we to do a few things -- When a pattern is annotated with a multiplicity annotation `let %q pat = rhs +- (NVP1) When a pattern is annotated with a multiplicity annotation `let %q pat = rhs in body` (note: multiplicity-annotated bindings are always parsed as a PatBind, see Note [Multiplicity annotations] in Language.Haskell.Syntax.Binds), - then the let is never generalised (we use the NoGen plan). -- Whenever the typechecker infers an AbsBind *and* the inner binding is a + then the let is never generalised (we use the NoGen plan). We do this with a + dedicated test in decideGeneralisationPlan. +- (NVP2) Whenever the typechecker infers an AbsBind *and* the inner binding is a non-variable PatBind, then the multiplicity of the binding is inferred to be - Many. This is a little infelicitous: sometimes the typechecker infers an - AbsBind where it didn't need to. This may cause some programs to be spuriously - rejected, when NoMonoLocalBinds is on. -- LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether. + Many. We do this by calling manyIfPats in tcPolyInfer. This is a little + infelicitous: sometimes the typechecker infers an AbsBind where it didn't need + to. This may cause some programs to be spuriously rejected, when + NoMonoLocalBinds is on. +- (NVP3) LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether. +- (NVP4) Wrinkle: even when other conditions (including MonoLocalBinds), GHC + will generalise some binders, namely so-called closed binding groups. We need + to make sure that the test for (NVP1) has priority over the test for closed + binders. +- (NVP5) Wrinkle: Closed binding groups (NVP4) are usually fine to type with + multiplicity Many. But there's one exception: when there's no binder at all, + the binding group is considered closed. Even if the rhs contains arbitrary + variables. + f :: () %1 -> Bool + f x = let !() = x in True + + If we consider `!() = x` as a generalisable group (which does nothing anyway), + then (NVP2) will infer the pattern as multiplicity Many, and reject the + function. We don't want that, see also #25428. So we take care not to + generalise in this case, by excluding the no-binder case from automatic + generalisation in decideGeneralisationPlan. -} tcPolyInfer @@ -762,7 +779,7 @@ ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list -- AbsBinds which are PatBinds can't be linear. - -- See Note [Non-variable pattern bindings aren't linear] + -- See (NVP2) in Note [Non-variable pattern bindings aren't linear] ; binds' <- manyIfPats binds' ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos)) @@ -1871,12 +1888,17 @@ -- See Note [Always generalise top-level bindings] | has_mult_anns_and_pats = False - -- See Note [Non-variable pattern bindings aren't linear] + -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] - | IsGroupClosed _ True <- closed = True + | IsGroupClosed _ True <- closed + , not (null binders) = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway + -- -XMonoLocalBinds, and generalise anyway. + -- Except if 'fv' is empty: there is no binder to generalise, so + -- generalising does nothing. And trying to generalise hurts linear + -- types (see #25428). So we don't force it. + -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. | has_partial_sigs = True -- See Note [Partial type signatures and generalisation] diff --git a/GHC/Tc/Gen/Head.hs b/GHC/Tc/Gen/Head.hs --- a/GHC/Tc/Gen/Head.hs +++ b/GHC/Tc/Gen/Head.hs @@ -37,8 +37,6 @@ import GHC.Hs.Syn.Type import GHC.Tc.Gen.HsType -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) - import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) @@ -78,15 +76,14 @@ import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName ) -import GHC.Driver.Env import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import Control.Monad +import GHC.Rename.Unbound (WhatLooking(WL_Anything)) @@ -1164,46 +1161,11 @@ AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps - (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon - ATyVar name _ -> fail_tyvar name + (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon + ATyVar name _ -> failIllegalTyVal name _ -> failWithTc $ TcRnExpectedValueId thing } where - fail_tycon tc = do - gre <- getGlobalRdrEnv - let nm = tyConName tc - pprov = case lookupGRE_Name gre nm of - Just gre -> nest 2 (pprNameProvenance gre) - Nothing -> empty - err | isClassTyCon tc = ClassTE - | otherwise = TyConTE - fail_with_msg dataName nm pprov err - - fail_tyvar nm = - let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm)) - in fail_with_msg varName nm pprov TyVarTE - - fail_with_msg whatName nm pprov err = do - (import_errs, hints) <- get_suggestions whatName - unit_state <- hsc_units <$> getTopEnv - let - -- TODO: unfortunate to have to convert to SDoc here. - -- This should go away once we refactor ErrInfo. - hint_msg = vcat $ map ppr hints - import_err_msg = vcat $ map ppr import_errs - info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } - failWithTc $ TcRnMessageWithInfo unit_state ( - mkDetailedMessage info (TcRnIllegalTermLevelUse nm err)) - - get_suggestions ns = do - required_type_arguments <- xoptM LangExt.RequiredTypeArguments - if required_type_arguments && isVarNameSpace ns - then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments] - else do - let occ = mkOccNameFS ns (occNameFS (occName id_name)) - lcl_env <- getLocalRdrEnv - unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ) - return_id id = return (HsVar noExtField (noLocA id), idType id) {- Note [Suppress hints with RequiredTypeArguments] diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs --- a/GHC/Tc/Gen/HsType.hs +++ b/GHC/Tc/Gen/HsType.hs @@ -73,7 +73,10 @@ HoleMode(..), -- Error messages - funAppCtxt, addTyConFlavCtxt + funAppCtxt, addTyConFlavCtxt, + + -- Utils + tyLitFromLit, tyLitFromOverloadedLit, ) where import GHC.Prelude hiding ( head, init, last, tail ) @@ -140,6 +143,7 @@ import Data.List ( mapAccumL ) import Control.Monad import Data.Tuple( swap ) +import GHC.Types.SourceText {- ---------------------------- @@ -4687,3 +4691,22 @@ addTyConFlavCtxt name flav = addErrCtxt $ hsep [ text "In the", ppr flav , text "declaration for", quotes (ppr name) ] + +{- +************************************************************************ +* * + Utils for constructing TyLit +* * +************************************************************************ +-} + + +tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn) +tyLitFromLit (HsString x str) = Just (HsStrTy x str) +tyLitFromLit (HsChar x char) = Just (HsCharTy x char) +tyLitFromLit _ = Nothing + +tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn) +tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n) +tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s +tyLitFromOverloadedLit HsFractional{} = Nothing diff --git a/GHC/Tc/Gen/Match.hs b/GHC/Tc/Gen/Match.hs --- a/GHC/Tc/Gen/Match.hs +++ b/GHC/Tc/Gen/Match.hs @@ -501,6 +501,32 @@ -- coercion matching stuff in them. It's hard to avoid the -- potential for non-trivial coercions in tcMcStmt +{- +Note [Binding in list comprehension isn't linear] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`. +But, the way the desugaring works, we get something like + +case xs of + () : xs ' -> letrec next_stmt = … xs' … + +In the current typing rules for letrec in Core, next_stmt is necessarily of +multiplicity Many and so is every free variable, including xs'. Which, in turns, +requires xs to be of multiplicity Many. + +Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having +non-Many multiplicities. But it's a fair bit of work to implement. + +Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then +we just conservatively make it unrestricted instead. + +If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]] +isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have +to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh +multiplicity variable. We'd also use the same multiplicity variable in the call +to `tcCheckPat` instead of `unrestricted`. +-} + tcLcStmt :: TyCon -- The list type constructor ([]) -> TcExprStmtChecker @@ -512,20 +538,24 @@ -- A generator, pat <- rhs tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) + -- About the next `tcScalingUsage ManyTy` and unrestricted + -- see Note [Binding in list comprehension isn't linear] + ; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + tcScalingUsage ManyTy $ thing_inside elt_ty ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside = do { rhs' <- tcCheckMonoExpr rhs boolTy - ; thing <- thing_inside elt_ty + ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } -- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions] tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { env <- getLocalRdrEnv + = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear. + do { env <- getLocalRdrEnv ; (pairs', thing) <- loop env [] bndr_stmts_s ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where @@ -551,7 +581,8 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap + = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many + do { let (bndr_names, n_bndr_names) = unzip bindersMap unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) -- The inner 'stmts' lack a LastStmt, so the element type -- passed in to tcStmtsAndThen is never looked at diff --git a/GHC/Tc/Gen/Pat.hs b/GHC/Tc/Gen/Pat.hs --- a/GHC/Tc/Gen/Pat.hs +++ b/GHC/Tc/Gen/Pat.hs @@ -78,6 +78,8 @@ import Data.List( partition ) import Data.Maybe (isJust) +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class {- ************************************************************************ @@ -504,55 +506,108 @@ ; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp) ; return (pat', result) } + -- Convert a Pat into the equivalent HsTyPat. -- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart. -- The `TcM` monad is only used to fail on ill-formed type patterns. pat_to_type_pat :: Pat GhcRn -> TcM (HsTyPat GhcRn) -pat_to_type_pat (EmbTyPat _ tp) = return tp -pat_to_type_pat (VarPat _ lname) = return (HsTP x b) +pat_to_type_pat pat = do + (ty, x) <- runWriterT (pat_to_type pat) + pure (HsTP (buildHsTyPatRn x) ty) + +pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) +pat_to_type (EmbTyPat _ (HsTP x t)) = + do { tell (builderFromHsTyPatRn x) + ; return t } +pat_to_type (VarPat _ lname) = + do { tell (tpBuilderExplicitTV (unLoc lname)) + ; return b } where b = noLocA (HsTyVar noAnn NotPromoted lname) - x = HsTPRn { hstp_nwcs = [] - , hstp_imp_tvs = [] - , hstp_exp_tvs = [unLoc lname] } -pat_to_type_pat (WildPat _) = return (HsTP x b) +pat_to_type (WildPat _) = return b where b = noLocA (HsWildCardTy noExtField) - x = HsTPRn { hstp_nwcs = [] - , hstp_imp_tvs = [] - , hstp_exp_tvs = [] } -pat_to_type_pat (SigPat _ pat sig_ty) - = do { HsTP x_hstp t <- pat_to_type_pat (unLoc pat) +pat_to_type (SigPat _ pat sig_ty) + = do { t <- pat_to_type (unLoc pat) ; let { !(HsPS x_hsps k) = sig_ty - ; x = append_hstp_hsps x_hstp x_hsps ; b = noLocA (HsKindSig noAnn t k) } - ; return (HsTP x b) } - where - -- Quadratic for nested signatures ((p :: t1) :: t2) - -- but those are unlikely to occur in practice. - append_hstp_hsps :: HsTyPatRn -> HsPSRn -> HsTyPatRn - append_hstp_hsps t p - = HsTPRn { hstp_nwcs = hstp_nwcs t ++ hsps_nwcs p - , hstp_imp_tvs = hstp_imp_tvs t ++ hsps_imp_tvs p - , hstp_exp_tvs = hstp_exp_tvs t } -pat_to_type_pat (ParPat _ pat) - = do { HsTP x t <- pat_to_type_pat (unLoc pat) - ; return (HsTP x (noLocA (HsParTy noAnn t))) } -pat_to_type_pat (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do - { HsTP x t <- pat_to_type_pat pat - ; return (HsTP x (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice))) } -pat_to_type_pat pat = - -- There are other cases to handle (ConPat, ListPat, TuplePat, etc), but these - -- would always be rejected by the unification in `tcHsTyPat`, so it's fine to - -- skip them here. This won't continue to be the case when visible forall is - -- permitted in data constructors: - -- - -- data T a where { Typed :: forall a -> a -> T a } - -- g :: T Int -> Int - -- g (Typed Int x) = x -- Note the `Int` type pattern - -- - -- See ticket #18389. When this feature lands, it would be best to extend - -- `pat_to_type_pat` to handle as many pattern forms as possible. + ; tell (tpBuilderPatSig x_hsps) + ; return b } +pat_to_type (ParPat _ pat) + = do { t <- pat_to_type (unLoc pat) + ; return (noLocA (HsParTy noAnn t)) } +pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do + { t <- pat_to_type pat + ; return (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice)) } + +pat_to_type (TuplePat _ pats Boxed) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitTupleTy noExtField tys) + ; pure t } +pat_to_type (ListPat _ pats) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys) + ; pure t } + +pat_to_type (LitPat _ lit) + | Just ty_lit <- tyLitFromLit lit + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t } +pat_to_type (NPat _ (L _ lit) _ _) + | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit) + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t} + +pat_to_type (ConPat _ lname (InfixCon left right)) + = do { lty <- pat_to_type (unLoc left) + ; rty <- pat_to_type (unLoc right) + ; let { t = noLocA (HsOpTy noAnn NotPromoted lty lname rty)} + ; pure t } +pat_to_type (ConPat _ lname (PrefixCon invis_args vis_args)) + = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname)} + ; ty_invis <- foldM apply_invis_arg appHead invis_args + ; tys_vis <- traverse (pat_to_type . unLoc) vis_args + ; let t = foldl' mkHsAppTy ty_invis tys_vis + ; pure t } + where + apply_invis_arg :: LHsType GhcRn -> HsConPatTyArg GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + apply_invis_arg !t (HsConPatTyArg _ (HsTP argx arg)) + = do { tell (builderFromHsTyPatRn argx) + ; pure (mkHsAppKindTy noExtField t arg)} + +pat_to_type pat = lift $ failWith $ TcRnIllformedTypePattern pat -- This failure is the only use of the TcM monad in `pat_to_type_pat` + +{- +Note [Pattern to type (P2T) conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + data T a b where + MkT :: forall a. forall b -> a -> b -> T a b + -- NB: `a` is invisible, but `b` is required + + f (MkT @[Int] (Maybe Bool) x y) = ... + +The second type argument of `MkT` is Required, so we write it without +an `@` sign in the pattern match. So the (Maybe Bool) will be + * parsed and renamed as a term pattern + * converted to a type when typechecking the pattern-match: the P2T conversion + +This is the only place we have P2T. In type-lambdas, the "pattern" is always a +type variable: + + f :: forall a -> a -> blah + f b (x::b) = ... + +The `b` argument must be a simple variable; we can't pattern-match on types. + +The function `pat_to_type` does the P2T conversion: + pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + +It is arranged as a writer monad, where the `HsTyPatRnBuilder` accumulates the +binders bound by the type. (We could discover these binders by a subsequent +traversal, that would mean writing another traversal.) +-} tc_ty_pat :: HsTyPat GhcRn -> TcTyVar -> TcM r -> TcM (TcType, r) tc_ty_pat tp tv thing_inside diff --git a/GHC/Tc/Instance/Family.hs b/GHC/Tc/Instance/Family.hs --- a/GHC/Tc/Instance/Family.hs +++ b/GHC/Tc/Instance/Family.hs @@ -58,6 +58,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Env (unitEnv_hpts) +import Data.List (sortOn) {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -239,6 +240,49 @@ a set of utility modules that every module imports directly or indirectly. This is basically the idea from #13092, comment:14. + +Note [Order of type family consistency checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a module M which imports modules A, B and C, all defining (open) type +family instances. + +We can waste a lot of work in type family consistency checking depending on the +order in which the modules are processed. + +Suppose for example that C imports A and B. When we compiled C, we will have +checked A and B for consistency against eachother. This means that, when +processing the imports of M to check type family instance consistency: + +* if C is processed first, then A and B will not need to be checked for + consistency against eachother again, +* if we process A and B before C,then the + consistency checks between A and B will be performed again. This is wasted + work, as we already performed them for C. + +This can make a significant difference. Keeping the nomenclature of the above +example for illustration, we have observed situations in practice in which the +compilation time of M goes from 1 second (the "processing A and B first" case) +down to 80 milliseconds (the "processing C first" case). + +Clearly we should engineer that C is checked before B and A, but by what scheme? + +A simple one is to observe that if a module M is in the transitive closure of X +then the size of the consistent family set of M is less than or equal to size +of the consistent family set of X. + +Therefore, by sorting the imports by the size of the consistent family set and +processing the largest first, we make sure to process modules in topological +order. + +For a particular project, without this change we did 40 million checks and with +this change we did 22.9 million checks. This is significant as before this change +type family consistency checks accounted for 26% of total type checker allocations which +was reduced to 15%. + +See tickets #25554 for discussion about this exact issue and #25555 for +why we still do redundant checks. + -} -- We don't need to check the current module, this is done in @@ -267,6 +311,12 @@ where deps = dep_finsts . mi_deps . modIface $ mod + ; debug_consistent_set = map (\x -> (x, length (modConsistent x))) directlyImpMods + + -- Sorting the list by size has the effect of performing a topological sort. + -- See Note [Order of type family consistency checks] + ; init_consistent_set = reverse (sortOn (length . modConsistent) directlyImpMods) + ; hmiModule = mi_module . hm_iface ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details @@ -276,7 +326,8 @@ } - ; checkMany hpt_fam_insts modConsistent directlyImpMods + ; traceTc "init_consistent_set" (ppr debug_consistent_set) + ; checkMany hpt_fam_insts modConsistent init_consistent_set } where -- See Note [Checking family instance optimization] @@ -294,6 +345,11 @@ -> TcM () go _ _ [] = return () go consistent consistent_set (mod:mods) = do + traceTc "checkManySize" (vcat [text "mod:" <+> ppr mod + , text "m1:" <+> ppr (length to_check_from_mod) + , text "m2:" <+> ppr (length (to_check_from_consistent)) + , text "product:" <+> ppr (length to_check_from_mod * length to_check_from_consistent) + ]) sequence_ [ check hpt_fam_insts m1 m2 | m1 <- to_check_from_mod diff --git a/GHC/Tc/Module.hs b/GHC/Tc/Module.hs --- a/GHC/Tc/Module.hs +++ b/GHC/Tc/Module.hs @@ -434,7 +434,9 @@ ; let { dir_imp_mods = moduleEnvKeys . imp_mods $ imports } - ; checkFamInstConsistency dir_imp_mods + ; logger <- getLogger + ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) + $ checkFamInstConsistency dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; getGblEnv } } @@ -709,7 +711,7 @@ -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds + <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds ; setGblEnv tcg_env $ do { -- Emit Typeable bindings @@ -1612,7 +1614,7 @@ traceTc "Tc3" empty ; (tcg_env, inst_infos, th_bndrs, XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; + <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ; updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ setGblEnv tcg_env $ do { @@ -1622,11 +1624,6 @@ (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - -- Value declarations next. -- It is important that we check the top-level value bindings -- before the GHC-generated derived bindings, since the latter @@ -1686,13 +1683,14 @@ addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; return (tcg_env', tcl_env) - }}}}}} + }}}}} tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" --------------------------- tcTyClsInstDecls :: [TyClGroup GhcRn] -> [LDerivDecl GhcRn] + -> [LDefaultDecl GhcRn] -> [(RecFlag, LHsBinds GhcRn)] -> TcM (TcGblEnv, -- The full inst env [InstInfo GhcRn], -- Source-code instance decls to @@ -1702,16 +1700,24 @@ HsValBinds GhcRn) -- Supporting bindings for derived -- instances -tcTyClsInstDecls tycl_decls deriv_decls binds +tcTyClsInstDecls tycl_decls deriv_decls default_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $ do { (tcg_env, inst_info, deriv_info, th_bndrs) <- tcTyAndClassDecls tycl_decls ; + ; setGblEnv tcg_env $ do { + -- With the @TyClDecl@s and @InstDecl@s checked we're ready to -- process the deriving clauses, including data family deriving -- clauses discovered in @tcTyAndClassDecls@. -- + -- But only after we've typechecked 'default' declarations. + -- See Note [Typechecking default declarations] + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ; failIfErrsM @@ -1720,7 +1726,7 @@ ; setGblEnv tcg_env' $ do { failIfErrsM ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) - }}} + }}}} {- ********************************************************************* * * @@ -3141,3 +3147,43 @@ pluginUnsafe = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin + + +-- Note [Typechecking default declarations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Typechecking default declarations requires careful placement: +-- +-- 1. We must check them after types (tcTyAndClassDecls) because they can refer +-- to them. E.g. +-- +-- data T = MkT ... +-- default(Int, T, Integer) +-- +-- -- or even (tested by T11974b and T2245) +-- default(Int, T, Integer) +-- data T = MkT ... +-- +-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv) +-- otherwise we may lookup default default types (Integer, Double) while checking +-- deriving clauses, ignoring the default declaration. +-- +-- Before this careful placement (#24566), compiling the following example +-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to +-- `applyDefaultingRules` with default types set to "(Integer,Double)": +-- +-- module M where +-- +-- import GHC.Classes +-- default () +-- +-- data Foo a = Nothing | Just a +-- deriving (Eq, Ord) +-- +-- This was an issue while building modules like M in the ghc-internal package +-- because they would spuriously fail to build if the module defining Integer +-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be +-- found. The implicit dependency between M and GHC.Num.Integer isn't known to +-- the build system. +-- In addition, trying to explicitly avoid the implicit dependency with `default +-- ()` didn't work, except if *standalone* deriving was used, which was an +-- inconsistent behavior. diff --git a/GHC/Tc/Solver/Equality.hs b/GHC/Tc/Solver/Equality.hs --- a/GHC/Tc/Solver/Equality.hs +++ b/GHC/Tc/Solver/Equality.hs @@ -311,7 +311,7 @@ -> Type -> Type -- RHS, after and before type-synonym expansion, resp -> TcS (StopOrContinue (Either IrredCt EqCt)) --- See Note [Comparing nullary type synonyms] in GHC.Core.Type. +-- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2 | tc1 == tc2 = canEqReflexive ev eq_rel ty1 @@ -2228,7 +2228,7 @@ `GHC.Tc.Solver.Monad.checkTypeEq`. Note its orientation: The type family ends up on the left; see -Note [Orienting TyFamLHS/TyFamLHS]d. No special treatment for +Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for CycleBreakerTvs is necessary. This scenario is now easily soluble, by using the first Given to rewrite the Wanted, which can now be solved. @@ -2900,8 +2900,7 @@ type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, ) + [W] F (alpha, beta) ~ (Int, ) The injectivity will give rise to constraints @@ -2917,8 +2916,8 @@ favour of alpha. If we instead had [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we grough it back in, it'd look like - [W] TF (gamma1, beta) ~ fuv +constraint. But when we substitute it back in, it'd look like + [W] F (gamma1, beta) ~ fuv and exactly the same thing would happen again! Infinite loop. This all seems fragile, and it might seem more robust to avoid @@ -2999,8 +2998,9 @@ | otherwise = do { fam_envs <- getFamInstEnvs ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) + ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args + , text "rhs:" <+> ppr rhs + , text "eqns:" <+> ppr eqns ]) ; unifyFunDeps ev Nominal $ \uenv -> uPairsTcM (bump_depth uenv) (reverse eqns) } -- Missing that `reverse` causes T13135 and T13135_simple to loop. @@ -3072,17 +3072,17 @@ -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) -> TcS [TypeEqn] injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) - = do { subst <- instFlexiX subst unsubstTvs + = do { subst1 <- instFlexiX subst unsubstTvs -- If the current substitution bind [k -> *], and -- one of the un-substituted tyvars is (a::k), we'd better -- be sure to apply the current substitution to a's kind. -- Hence instFlexiX. #13135 was an example. - ; return [ Pair (substTy subst ax_arg) arg + ; return [ Pair (substTy subst1 ax_arg) arg -- NB: the ax_arg part is on the left -- see Note [Improvement orientation] | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' + Just cabr' -> apartnessCheck (substTys subst1 ax_args) cabr' _ -> True , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } diff --git a/GHC/Tc/Types.hs b/GHC/Tc/Types.hs --- a/GHC/Tc/Types.hs +++ b/GHC/Tc/Types.hs @@ -534,6 +534,10 @@ tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. + tcg_zany_n :: TcRef Integer, + -- ^ A source of unique identities for ZonkAny instances + -- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) + tcg_merged :: [(Module, Fingerprint)], -- ^ The requirements we merged with; we always have to recompile -- if any of these changed. diff --git a/GHC/Tc/Types/Constraint.hs b/GHC/Tc/Types/Constraint.hs --- a/GHC/Tc/Types/Constraint.hs +++ b/GHC/Tc/Types/Constraint.hs @@ -83,7 +83,7 @@ ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, ctEvRewriters, ctEvUnique, tcEvDestUnique, mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc, - ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens, + ctEvRole, setCtEvPredType, setCtEvLoc, tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, -- RewriterSet @@ -1312,25 +1312,51 @@ insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) = anyBag insolubleWantedCt simples + -- insolubleWantedCt: wanteds only: see Note [Given insolubles] || anyBag insolubleImplic implics || anyBag is_insoluble errors - - where + where is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] is_insoluble (DE_NotConcrete {}) = True insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely: --- a) an insoluble constraint as per 'insolubleCt', i.e. either +-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either -- - an insoluble equality constraint (e.g. Int ~ Bool), or -- - a custom type error constraint, TypeError msg :: Constraint -- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- See Note [Insoluble Wanteds] +insolubleWantedCt ct + | CIrredCan ir_ct <- ct + -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] + , IrredCt { ir_ev = ev } <- ir_ct + , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev + -- It's a Wanted + , insolubleIrredCt ir_ct + -- It's insoluble + , isEmptyRewriterSet rewriters + -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + , not (isGivenLoc loc) + -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) + -- origin check: see (IW4) in Note [Insoluble Wanteds] + = True + + | otherwise + = False + +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. -- --- See Note [Given insolubles]. -insolubleWantedCt ct = insolubleCt ct && - not (arisesFromGivens ct) && - not (isWantedWantedFunDepOrigin (ctOrigin ct)) +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble @@ -1360,18 +1386,6 @@ -- > Assert 'True _errMsg = () -- > Assert _check errMsg = errMsg --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan -insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool @@ -1415,6 +1429,31 @@ Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) should ignore givens even if they are insoluble. +Note [Insoluble Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~ +insolubleWantedCt returns True of a Wanted constraint that definitely +can't be solved. But not quite all such constraints; see wrinkles. + +(IW1) insolubleWantedCt is tuned for application /after/ constraint + solving i.e. assuming canonicalisation has been done. That's why + it looks only for IrredCt; all insoluble constraints are put into + CIrredCan + +(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note + [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A + that is /not/ insoluble rewrites some other Wanted constraint B, so B has A + in its rewriter set. Now B looks insoluble. The danger is that we'll + suppress reporting B because of its empty rewriter set; and suppress + reporting A because there is an insoluble B lying around. (This suppression + happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. + +(IW3) If the Wanted arises from a Given (how can that happen?), don't + treat it as a Wanted insoluble (obviously). + +(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't + treat the constraint as insoluble. See Note [Suppressing confusing errors] + in GHC.Tc.Errors + Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble: @@ -2055,9 +2094,6 @@ setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc } - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- | Set the type of CtEvidence. -- diff --git a/GHC/Tc/Types/Evidence.hs b/GHC/Tc/Types/Evidence.hs --- a/GHC/Tc/Types/Evidence.hs +++ b/GHC/Tc/Types/Evidence.hs @@ -7,7 +7,7 @@ -- * HsWrapper HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpVisTyLam, + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast, mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, @@ -258,20 +258,20 @@ mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids --- Construct a type lambda and cast its type --- from `forall tv. res` to `forall tv -> res`. --- --- (\ @tv -> e ) --- `cast` (forall (tv[spec]~[req] :: <*>_N). _R -- ForAllCo is the evidence that... --- :: (forall tv. res) ~R# (forall tv -> res)) -- invisible and visible foralls are representationally equal +-- mkWpForAllCast [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep -- -mkWpVisTyLam :: TyVar -> Type -> HsWrapper -mkWpVisTyLam tv res = - WpCast (mkForAllCo tv coreTyLamForAllTyFlag Required kind_co body_co) - <.> WpTyLam tv +-- It's a no-op if all binders are invisible; +-- but in that case we refrain from calling it. +mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper +mkWpForAllCast bndrs res_ty + = mkWpCastR (go bndrs) where - kind_co = mkNomReflCo (varType tv) - body_co = mkRepReflCo res + go [] = mkRepReflCo res_ty + go (Bndr tv vis : bs) = mkForAllCo tv coreTyLamForAllTyFlag vis kind_co (go bs) + where + kind_co = mkNomReflCo (varType tv) mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids diff --git a/GHC/Tc/Types/LclEnv.hs-boot b/GHC/Tc/Types/LclEnv.hs-boot --- a/GHC/Tc/Types/LclEnv.hs-boot +++ b/GHC/Tc/Types/LclEnv.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Types.LclEnv where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data TcLclEnv diff --git a/GHC/Tc/Utils/Env.hs b/GHC/Tc/Utils/Env.hs --- a/GHC/Tc/Utils/Env.hs +++ b/GHC/Tc/Utils/Env.hs @@ -28,6 +28,7 @@ tcLookupLocatedClass, tcLookupAxiom, lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds, + failIllegalTyCon, failIllegalTyVal, -- Local environment tcExtendKindEnv, tcExtendKindEnvList, @@ -137,6 +138,7 @@ import Control.Monad import GHC.Iface.Errors.Types import GHC.Types.Error +import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) {- ********************************************************************* * * @@ -278,6 +280,7 @@ thing <- tcLookupGlobal name case thing of AConLike cl -> return cl + ATyCon tc -> failIllegalTyCon WL_Constructor tc _ -> wrongThingErr WrongThingConLike (AGlobal thing) name tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent @@ -349,6 +352,45 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where lookupThing = tcLookupGlobal +-- Illegal term-level use of type things +failIllegalTyCon :: WhatLooking -> TyCon -> TcM a +failIllegalTyVal :: Name -> TcM a +(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar) + where + fail_tycon what_looking tc = do + gre <- getGlobalRdrEnv + let nm = tyConName tc + pprov = case lookupGRE_Name gre nm of + Just gre -> nest 2 (pprNameProvenance gre) + Nothing -> empty + err | isClassTyCon tc = ClassTE + | otherwise = TyConTE + fail_with_msg what_looking dataName nm pprov err + + fail_tyvar nm = + let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm)) + in fail_with_msg WL_Anything varName nm pprov TyVarTE + + fail_with_msg what_looking whatName nm pprov err = do + (import_errs, hints) <- get_suggestions what_looking whatName nm + unit_state <- hsc_units <$> getTopEnv + let + -- TODO: unfortunate to have to convert to SDoc here. + -- This should go away once we refactor ErrInfo. + hint_msg = vcat $ map ppr hints + import_err_msg = vcat $ map ppr import_errs + info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } + failWithTc $ TcRnMessageWithInfo unit_state ( + mkDetailedMessage info (TcRnIllegalTermLevelUse nm err)) + + get_suggestions what_looking ns nm = do + required_type_arguments <- xoptM LangExt.RequiredTypeArguments + if required_type_arguments && isVarNameSpace ns + then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments] + else do + let occ = mkOccNameFS ns (occNameFS (occName nm)) + lcl_env <- getLocalRdrEnv + unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ) {- ************************************************************************ * * @@ -888,7 +930,7 @@ {- Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~ In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we try when defaulting. This has very little real impact, except in the following case. Consider: diff --git a/GHC/Tc/Utils/Instantiate.hs b/GHC/Tc/Utils/Instantiate.hs --- a/GHC/Tc/Utils/Instantiate.hs +++ b/GHC/Tc/Utils/Instantiate.hs @@ -11,7 +11,7 @@ -} module GHC.Tc.Utils.Instantiate ( - topSkolemise, + topSkolemise, skolemiseRequired, topInstantiate, instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, @@ -75,7 +75,7 @@ import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Types.Basic ( TypeOrKind(..), Arity ) +import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity ) import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc @@ -145,22 +145,16 @@ Note [Skolemisation] ~~~~~~~~~~~~~~~~~~~~ topSkolemise decomposes and skolemises a type, returning a type -with no top level foralls or (=>) +with no top level foralls or (=>). Examples: topSkolemise (forall a. Ord a => a -> a) = ( wp, [a], [d:Ord a], a->a ) - where wp = /\a. \(d:Ord a). a d - - topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) - where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + where + wp = /\a. \(d:Ord a). a d -This second example is the reason for the recursive 'go' function in -topSkolemise: we remove successive layers of foralls and (=>). This -is really just an optimisation; see wrinkle (SK1) in GHC.Tc.Utils.Unify -Note [Skolemisation overview]. +For nested foralls, see Note [Skolemisation en-bloc] In general, if topSkolemise ty = (wrap, tvs, evs, rho) @@ -168,6 +162,41 @@ then wrap e :: ty and 'wrap' binds {tvs, evs} +Note [Skolemisation en-bloc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this case: + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + +We /could/ return just + (wp, [a], [d:Ord a, forall b. Eq b => a -> b -> b) + +But in fact we skolemise "en-bloc", looping around (in `topSkolemise` for +example) to skolemise the (forall b. Eq b =>). So in fact + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) + where + wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + +This applies regardless of DeepSubsumption. + +Why do we do this "en-bloc" loopy thing? It is /nearly/ just an optimisation. +But not quite! At the call site of `topSkolemise` (and its cousins) we +use `checkConstraints` to gather constraints and build an implication +constraint. So skolemising just one level at a time would lead to nested +implication constraints. That is a bit less efficient, but there is /also/ a small +user-visible effect: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet. +Specifically, consider + + forall a. Eq a => forall b. (a ~ [b]) => blah + +If we skolemise en-bloc, the equality (a~[b]) is like a let-binding and we +don't treat it like a GADT pattern match, limiting unification. With nested +implications, the inner one would be treated as having-given-equalities. + +This is also relevant when Required foralls are involved; see #24810, and +the loop in `skolemiseRequired`. -} topSkolemise :: SkolemInfo @@ -182,7 +211,7 @@ where init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - -- Why recursive? See Note [Skolemisation] + -- Why recursive? See Note [Skolemisation en-bloc] go subst wrap tv_prs ev_vars ty | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty , let tvs = binderVars bndrs @@ -200,6 +229,51 @@ | otherwise = return (wrap, tv_prs, ev_vars, substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +skolemiseRequired :: SkolemInfo -> VisArity -> TcSigmaType + -> TcM (VisArity, HsWrapper, [Name], [ForAllTyBinder], [EvVar], TcRhoType) +-- Skolemise up to N required (visible) binders, +-- plus any invisible ones "in the way", +-- /and/ any trailing invisible ones. +-- So the result has no top-level invisible quantifiers. +-- Return the depleted arity. +skolemiseRequired skolem_info n_req sigma + = go n_req init_subst idHsWrapper [] [] [] sigma + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma)) + + -- Why recursive? See Note [Skolemisation en-bloc] + go n_req subst wrap acc_nms acc_bndrs ev_vars ty + | (n_req', bndrs, inner_ty) <- tcSplitForAllTyVarsReqTVBindersN n_req ty + , not (null bndrs) + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 + -- fix_up_vis: see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep + fix_up_vis | n_req == n_req' + = idHsWrapper + | otherwise + = mkWpForAllCast bndrs1 (substTy subst' inner_ty) + ; go n_req' subst' + (wrap <.> fix_up_vis <.> mkWpTyLams tvs1) + (acc_nms ++ map (tyVarName . binderVar) bndrs) + (acc_bndrs ++ bndrs1) + ev_vars + inner_ty } + + | (theta, inner_ty) <- tcSplitPhiTy ty + , not (null theta) + = do { ev_vars1 <- newEvVars (substTheta subst theta) + ; go n_req subst + (wrap <.> mkWpEvLams ev_vars1) + acc_nms + acc_bndrs + (ev_vars ++ ev_vars1) + inner_ty } + + | otherwise + = return (n_req, wrap, acc_nms, acc_bndrs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) diff --git a/GHC/Tc/Utils/Monad.hs b/GHC/Tc/Utils/Monad.hs --- a/GHC/Tc/Utils/Monad.hs +++ b/GHC/Tc/Utils/Monad.hs @@ -142,7 +142,7 @@ getCCIndexM, getCCIndexTcM, -- * Zonking - liftZonkM, + liftZonkM, newZonkAnyType, -- * Types etc. module GHC.Tc.Types, @@ -153,6 +153,7 @@ import GHC.Builtin.Names +import GHC.Builtin.Types( zonkAnyTyCon ) import GHC.Tc.Errors.Types import GHC.Tc.Types -- Re-export all @@ -175,6 +176,7 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import GHC.Core.Type( mkNumLitTy ) import GHC.Driver.Env import GHC.Driver.Session @@ -254,6 +256,7 @@ infer_var <- newIORef True ; infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ; + zany_n_var <- newIORef 0 ; let { type_env_var = hsc_type_env_vars hsc_env }; dependent_files_var <- newIORef [] ; @@ -345,6 +348,7 @@ tcg_patsyns = [], tcg_merged = [], tcg_dfun_n = dfun_n_var, + tcg_zany_n = zany_n_var, tcg_keep = keep_var, tcg_hdr_info = (Nothing,Nothing), tcg_hpc = False, @@ -1801,6 +1805,18 @@ ; let occ = fn set ; writeTcRef dfun_n_var (extendOccSet set occ) ; return occ } + +newZonkAnyType :: Kind -> TcM Type +-- Return a type (ZonkAny @k n), where n is fresh +-- Recall ZonkAny :: forall k. Natural -> k +-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) +newZonkAnyType kind + = do { env <- getGblEnv + ; let zany_n_var = tcg_zany_n env + ; i <- readTcRef zany_n_var + ; let !i2 = i+1 + ; writeTcRef zany_n_var i2 + ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) } getConstraintVar :: TcM (TcRef WantedConstraints) getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs --- a/GHC/Tc/Utils/TcType.hs +++ b/GHC/Tc/Utils/TcType.hs @@ -67,7 +67,7 @@ -------------------------------- -- Splitters getTyVar, getTyVar_maybe, getCastedTyVar_maybe, - tcSplitForAllTyVarBinder_maybe, + tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders, @@ -95,7 +95,7 @@ -- Re-exported from GHC.Core.TyCo.Compare -- mainly just for back-compat reasons eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical, tcEqTyConApps, eqForAllVis, eqVarBndrs, --------------------------------- @@ -888,7 +888,8 @@ -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a -- /visible/ argument to @C@. -- --- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". +-- See also Note [Showing invisible bits of types in error messages] +-- in "GHC.Tc.Errors.Ppr". tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVis = tcTyFamInstsAndVisX False @@ -1405,6 +1406,18 @@ | argf_pred argf = split ty ty (tv:tvs) split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) + +tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type) +-- Split off at most N /required/ (aka visible) binders, plus any invisible ones +-- in the way, /and/ any trailing invisible ones +tcSplitForAllTyVarsReqTVBindersN n_req ty + = split n_req ty ty [] + where + split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs + | isVisibleForAllTyFlag argf, n_req > 0 = split (n_req - 1) ty ty (b:bs) + | otherwise = split n_req ty ty (b:bs) + split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs + split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty) -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. diff --git a/GHC/Tc/Utils/Unify.hs b/GHC/Tc/Utils/Unify.hs --- a/GHC/Tc/Utils/Unify.hs +++ b/GHC/Tc/Utils/Unify.hs @@ -348,9 +348,9 @@ The implication constraint will look like forall a b. (Eq a, Ord b) => See the loop in GHC.Tc.Utils.Instantiate.topSkolemise. - This is just an optimisation; it would be fine to generate one implication - constraint for each nesting layer. + and Note [Skolemisation en-bloc] in that module + Some examples: * f :: forall a b. blah @@ -775,29 +775,40 @@ ; return (mkWpCastN co, result) } matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside - = check 0 [] top_ty + = check arity [] top_ty where check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a) -- `check` is called only in the Check{} case -- It collects rev_pat_tys in reversed order - -- n_so_far is the number of /visible/ arguments seen so far: - -- i.e. length (filterOut isExpForAllPatTyInvis rev_pat_tys) + -- n_req is the number of /visible/ arguments still needed - -- Do shallow skolemisation if there are top-level invisible quantifiers - check n_so_far rev_pat_tys ty - | isSigmaTy ty -- Type has invisible quantifiers - = do { (wrap_gen, (wrap_res, result)) - <- tcSkolemiseGeneral Shallow ctx top_ty ty $ \tv_bndrs ty' -> - let rev_pat_tys' = reverse (map (mkInvisExpPatType . snd) tv_bndrs) - ++ rev_pat_tys - in check n_so_far rev_pat_tys' ty' - ; return (wrap_gen <.> wrap_res, result) } + ---------------------------- + -- Skolemise quantifiers, both visible (up to n_req) and invisible + -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App + check n_req rev_pat_tys ty + | isSigmaTy ty -- An invisible quantifier at the top + || (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it + = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty + ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs) + skol_tvs = binderVars bndrs + ; skol_info <- mkSkolemInfo sig_skol } + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; (ev_binds, (wrap_res, result)) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + check n_req' + (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys) + inner_ty + ; assertPpr (not (null bndrs && null given)) (ppr ty) $ + -- The guard ensures that we made some progress + return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) } - -- (n_so_far == arity): no more args - -- rho_ty has no top-level quantifiers - -- If there is deep subsumption, do deep skolemisation - check n_so_far rev_pat_tys rho_ty - | n_so_far == arity + ---------------------------- + -- Base case: (n_req == 0): no more args + -- The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers + -- If there is deep subsumption, do deep skolemisation now + check n_req rev_pat_tys rho_ty + | n_req == 0 = do { let pat_tys = reverse rev_pat_tys ; ds_flag <- getDeepSubsumptionFlag ; case ds_flag of @@ -808,53 +819,35 @@ -- They do not line up with binders in the Match thing_inside pat_tys (mkCheckExpType rho_ty) } - -- NOW do coreView. We didn't do it before, so that we do not unnecessarily - -- unwrap a synonym in the returned rho_ty - check n_so_far rev_pat_tys ty - | Just ty' <- coreView ty = check n_so_far rev_pat_tys ty' - - -- Decompose /visible/ (forall a -> blah), to give an ExpForAllPat - -- NB: invisible binders are handled by tcSplitSigmaTy/tcTopSkolemise above - -- NB: visible foralls "count" for the Arity argument; they correspond - -- to syntactically visible patterns in the source program - -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App - check n_so_far rev_pat_tys ty - | Just (Bndr tv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty - = assertPpr (isVisibleForAllTyFlag vis) (ppr ty) $ - -- isSigmaTy case above has dealt with /invisible/ quantifiers, - -- so this one must be /visible/ (= Required) - do { let init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - ; rec { (subst', [tv']) <- tcInstSkolTyVarsX skol_info init_subst [tv] - ; let tv_prs = [(tyVarName tv, tv')] - ; skol_info <- mkSkolemInfo (SigSkol ctx top_ty tv_prs) } - ; let body_ty' = substTy subst' body_ty - pat_ty = ExpForAllPatTy (mkForAllTyBinder Required tv') - ; (ev_binds, (wrap_res, result)) <- checkConstraints (getSkolemInfo skol_info) [tv'] [] $ - check (n_so_far+1) (pat_ty : rev_pat_tys) body_ty' - ; let wrap_gen = mkWpVisTyLam tv' body_ty' <.> mkWpLet ev_binds - ; return (wrap_gen <.> wrap_res, result) } - - check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult - , ft_arg = arg_ty, ft_res = res_ty }) + ---------------------------- + -- Function types + check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult + , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { let arg_pos = n_so_far + 1 + do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty - ; (wrap_res, result) <- check arg_pos + ; (wrap_res, result) <- check (n_req - 1) (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys) res_ty ; let wrap_arg = mkWpCastN arg_co fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty ; return (fun_wrap, result) } - check n_so_far rev_pat_tys ty@(TyVarTy tv) + ---------------------------- + -- Type variables + check n_req rev_pat_tys ty@(TyVarTy tv) | isMetaTyVar tv = do { cts <- readMetaTyVar tv ; case cts of - Indirect ty' -> check n_so_far rev_pat_tys ty' - Flexi -> defer n_so_far rev_pat_tys ty } + Indirect ty' -> check n_req rev_pat_tys ty' + Flexi -> defer n_req rev_pat_tys ty } + ---------------------------- + -- NOW do coreView. We didn't do it before, so that we do not unnecessarily + -- unwrap a synonym in the returned rho_ty + check n_req rev_pat_tys ty + | Just ty' <- coreView ty = check n_req rev_pat_tys ty' + -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the -- number of arguments doesn't match arity of the original @@ -870,14 +863,14 @@ -- -- But in that case we add specialized type into error context -- anyway, because it may be useful. See also #9605. - check n_so_far rev_pat_tys res_ty + check n_req rev_pat_tys res_ty = addErrCtxtM (mkFunTysMsg herald (arity, top_ty)) $ - defer n_so_far rev_pat_tys res_ty + defer n_req rev_pat_tys res_ty ------------ defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a) - defer n_so_far rev_pat_tys fun_ty - = do { more_arg_tys <- mapM (new_check_arg_ty herald) [n_so_far + 1 .. arity] + defer n_req rev_pat_tys fun_ty + = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity] ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys ; res_ty <- newOpenFlexiTyVarTy ; result <- thing_inside all_pats (mkCheckExpType res_ty) @@ -892,7 +885,7 @@ ; return (mkScaled mult inf_hole) } new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) -new_check_arg_ty herald arg_pos -- Position for error messages only +new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } @@ -2367,7 +2360,14 @@ do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs -- Attempt to unify kinds - ; co_k <- uType (mkKindEnv env ty1 ty2) (typeKind ty2) (tyVarKind tv1) + -- When doing so, be careful to preserve orientation; + -- see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality + -- and wrinkle (W2) in Note [Fundeps with instances, and equality orientation] + -- in GHC.Tc.Solver.Dict + -- Failing to preserve orientation led to #25597. + ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2 + ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2) + ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) diff --git a/GHC/Tc/Zonk/Type.hs b/GHC/Tc/Zonk/Type.hs --- a/GHC/Tc/Zonk/Type.hs +++ b/GHC/Tc/Zonk/Type.hs @@ -54,7 +54,7 @@ import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Monad ( setSrcSpanA, liftZonkM, traceTc, addErr ) +import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types @@ -468,8 +468,9 @@ -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) ; return (anyTypeOfKind zonked_kind) } | otherwise - -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) - ; return (anyTypeOfKind zonked_kind) } + -> do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv) + -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4) + ; newZonkAnyType zonked_kind } RuntimeUnkFlexi -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -1485,7 +1485,8 @@ ; return $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } + ; let pp = parenthesizePat sigPrec p' + ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'} cvtp (TypeP t) = do { t' <- cvtType t diff --git a/GHC/Types/BreakInfo.hs b/GHC/Types/BreakInfo.hs deleted file mode 100644 --- a/GHC/Types/BreakInfo.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and --- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module --- dependency tree -module GHC.Types.BreakInfo (BreakInfo(..)) where - -import GHC.Prelude -import GHC.Unit.Module - -data BreakInfo = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: Int - } diff --git a/GHC/Types/Breakpoint.hs b/GHC/Types/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Breakpoint.hs @@ -0,0 +1,53 @@ +-- | Breakpoint related types +module GHC.Types.Breakpoint + ( BreakpointId (..) + , InternalBreakpointId (..) + , toBreakpointId + ) +where + +import GHC.Prelude +import GHC.Unit.Module + +-- | Breakpoint identifier. +-- +-- See Note [Breakpoint identifiers] +data BreakpointId = BreakpointId + { bi_tick_mod :: !Module -- ^ Breakpoint tick module + , bi_tick_index :: !Int -- ^ Breakpoint tick index + } + +-- | Internal breakpoint identifier +-- +-- See Note [Breakpoint identifiers] +data InternalBreakpointId = InternalBreakpointId + { ibi_tick_mod :: !Module -- ^ Breakpoint tick module + , ibi_tick_index :: !Int -- ^ Breakpoint tick index + , ibi_info_mod :: !Module -- ^ Breakpoint info module + , ibi_info_index :: !Int -- ^ Breakpoint info index + } + +toBreakpointId :: InternalBreakpointId -> BreakpointId +toBreakpointId ibi = BreakpointId + { bi_tick_mod = ibi_tick_mod ibi + , bi_tick_index = ibi_tick_index ibi + } + + +-- Note [Breakpoint identifiers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Before optimization a breakpoint is identified uniquely with a tick module +-- and a tick index. See BreakpointId. A tick module contains an array, indexed +-- with the tick indexes, which indicates breakpoint status. +-- +-- When we generate ByteCode, we collect information for every breakpoint at +-- their *occurrence sites* (see CgBreakInfo in GHC.ByteCode.Types) and these info +-- are stored in the ModIface of the occurrence module. Because of inlining, we +-- can't reuse the tick index to uniquely identify an occurrence; because of +-- cross-module inlining, we can't assume that the occurrence module is the same +-- as the tick module (#24712). +-- +-- So every breakpoint occurrence gets assigned a module-unique *info index* and +-- we store it alongside the occurrence module (*info module*) in the +-- InternalBreakpointId datatype. diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs --- a/GHC/Types/Demand.hs +++ b/GHC/Types/Demand.hs @@ -37,7 +37,7 @@ -- *** Demands used in PrimOp signatures lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd, -- ** Other @Demand@ operations - oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, + oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information @@ -607,22 +607,22 @@ -- -- Examples (using Note [Demand notation]): -- --- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument --- strictly (@1@), but not any deeper (@A@). --- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument +-- * 'seq' puts demand `1A` on its first argument: It evaluates the argument +-- strictly (`1`), but not any deeper (`A`). +-- * 'fst' puts demand `1P(1L,A)` on its argument: It evaluates the argument -- pair strictly and the first component strictly, but no nested info --- beyond that (@L@). Its second argument is not used at all. --- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the --- argument function with one argument, exactly once (@1@). No info --- on how the result of that call is evaluated (@L@). --- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates +-- beyond that (`L`). Its second argument is not used at all. +-- * '$' puts demand `1C(1,L)` on its first argument: It calls (`C`) the +-- argument function with one argument, exactly once (`1`). No info +-- on how the result of that call is evaluated (`L`). +-- * 'maybe' puts demand `MC(M,L)` on its second argument: It evaluates -- the argument function at most once ((M)aybe) and calls it once when -- it is evaluated. --- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@ --- multiplied by two, so we get @S@ (used at least once, possibly multiple +-- * `fst p + fst p` puts demand `SP(SL,A)` on `p`: It's `1P(1L,A)` +-- multiplied by two, so we get `S` (used at least once, possibly multiple -- times). -- --- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled +-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there @@ -1012,6 +1012,11 @@ lazifyDmd :: Demand -> Demand lazifyDmd = multDmd C_01 +-- | Adjust the demand on a binding that may float outwards +-- See Note [Floatifying demand info when floating] +floatifyDmd :: Demand -> Demand +floatifyDmd = multDmd C_0N + -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd @@ -2634,7 +2639,12 @@ but it's always clear from context which "overload" is meant. It's like return-type inference of e.g. 'read'. -Examples are in the haddock for 'Demand'. +Examples are in the haddock for 'Demand'. Here are some more: + SA Strict, but does not look at subcomponents (`seq`) + SP(L,L) Strict boxed pair, components lazy + S!P(L,L) Strict unboxed pair, components lazy + LP(SA,SA) Lazy pair, but if it is evaluated will evaluated its components + LC(1C(L)) Lazy, but if called will apply the result exactly once This is the syntax for demand signatures: diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs --- a/GHC/Types/Id.hs +++ b/GHC/Types/Id.hs @@ -54,7 +54,7 @@ setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, @@ -296,26 +296,28 @@ mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - +mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo nm = + assertPpr (not $ isFieldNameSpace $ nameNameSpace nm) + (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $ + mkGlobalId VanillaId nm -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold. @@ -339,7 +341,10 @@ -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo +mkExportedVanillaId name ty = + assertPpr (not $ isFieldNameSpace $ nameNameSpace name) + (text "mkExportedVanillaId called on record field:" <+> ppr name) $ + Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] @@ -958,12 +963,11 @@ updOneShotInfo :: Id -> OneShotInfo -> Id -- Combine the info in the Id with new info updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False + | OneShotLam <- one_shot + , NoOneShotInfo <- idOneShotInfo id + = setIdOneShotInfo id OneShotLam + | otherwise + = id -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else @@ -980,8 +984,9 @@ zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo +floatifyIdDemandInfo :: Id -> Id +-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels +floatifyIdDemandInfo = zapInfo floatifyDemandInfo zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo diff --git a/GHC/Types/Id.hs-boot b/GHC/Types/Id.hs-boot --- a/GHC/Types/Id.hs-boot +++ b/GHC/Types/Id.hs-boot @@ -1,6 +1,5 @@ module GHC.Types.Id where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name import {-# SOURCE #-} GHC.Types.Var diff --git a/GHC/Types/Id/Info.hs b/GHC/Types/Id/Info.hs --- a/GHC/Types/Id/Info.hs +++ b/GHC/Types/Id/Info.hs @@ -35,7 +35,8 @@ -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + lazifyDemandInfo, floatifyDemandInfo, + zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, zapTailCallInfo, zapCallArityInfo, trimUnfolding, -- ** The ArityInfo type @@ -855,11 +856,21 @@ is_safe_dmd dmd = not (isStrUsedDmd dmd) --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) +-- | Lazify (remove the top-level demand, only) the demand in `IdInfo` +-- Keep nested demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +lazifyDemandInfo :: IdInfo -> Maybe IdInfo +lazifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = lazifyDmd dmd }) --- | Remove usage (but not strictness) info on the 'IdInfo' +-- | Floatify the demand in `IdInfo` +-- But keep /nested/ demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +floatifyDemandInfo :: IdInfo -> Maybe IdInfo +floatifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = floatifyDmd dmd }) + +-- | Remove usage (but not strictness) info on the `IdInfo` zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) diff --git a/GHC/Types/Id/Make.hs b/GHC/Types/Id/Make.hs --- a/GHC/Types/Id/Make.hs +++ b/GHC/Types/Id/Make.hs @@ -902,15 +902,25 @@ -- needs a wrapper. This wrapper is injected into the program later in the -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, -- along with the accompanying implementation in getTyConImplicitBinds. - wrapper_reqd = - (not new_tycon + wrapper_reqd + | isTypeDataTyCon tycon + -- `type data` declarations never have data-constructor wrappers + -- Their data constructors only live at the type level, in the + -- form of PromotedDataCon, and therefore do not need wrappers. + -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module. + = False + + | otherwise + = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec) + || isFamInstTyCon tycon -- Cast result - || (dataConUserTyVarsNeedWrapper data_con + + || dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder @@ -919,19 +929,7 @@ -- -- NB: All GADTs return true from this function, but there -- is one exception that we must check below. - && not (isTypeDataTyCon tycon)) - -- An exception to this rule is `type data` declarations. - -- Their data constructors only live at the type level and - -- therefore do not need wrappers. - -- See Note [Type data declarations] in GHC.Rename.Module. - -- - -- Note that the other checks in this definition will - -- return False for `type data` declarations, as: - -- - -- - They cannot be newtypes - -- - They cannot have strict fields - -- - They cannot be data family instances - -- - They cannot have datatype contexts + || not (null stupid_theta) -- If the data constructor has a datatype context, -- we need a wrapper in order to drop the stupid arguments. diff --git a/GHC/Types/Name/Ppr.hs b/GHC/Types/Name/Ppr.hs --- a/GHC/Types/Name/Ppr.hs +++ b/GHC/Types/Name/Ppr.hs @@ -123,7 +123,8 @@ , fUNTyConName, unrestrictedFunTyConName , oneDataConName , listTyConName - , manyDataConName ] + , manyDataConName + , soloDataConName ] || isJust (isTupleTyOcc_maybe mod occ) || isJust (isSumTyOcc_maybe mod occ) diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs --- a/GHC/Types/RepType.hs +++ b/GHC/Types/RepType.hs @@ -693,6 +693,9 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty + -- Currently ghc has no unlifted functions. + | definitelyUnliftedType ty + = False | [BoxedRep _] <- typePrimRep ty , Just tc <- tyConAppTyCon_maybe (unwrapType ty) , isDataTyCon tc diff --git a/GHC/Types/Var.hs b/GHC/Types/Var.hs --- a/GHC/Types/Var.hs +++ b/GHC/Types/Var.hs @@ -503,7 +503,7 @@ coreTyLamForAllTyFlag :: ForAllTyFlag -- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable. -- If you want other ForAllTyFlag, use a cast. --- See Note [ForAllCo] in GHC.Core.TyCo.Rep +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep coreTyLamForAllTyFlag = Specified instance Outputable ForAllTyFlag where diff --git a/GHC/Types/Var.hs-boot b/GHC/Types/Var.hs-boot --- a/GHC/Types/Var.hs-boot +++ b/GHC/Types/Var.hs-boot @@ -1,13 +1,7 @@ {-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name - -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports - -- it does not seem to depend on anything. But it does! We must, for - -- example, compile GHC.Types in the ghc-prim library first. So this - -- otherwise-unnecessary import tells the build system that this module - -- depends on GhcPrelude, which ensures that GHC.Type is built first. data ForAllTyFlag data FunTyFlag diff --git a/GHC/Unit/Types.hs b/GHC/Unit/Types.hs --- a/GHC/Unit/Types.hs +++ b/GHC/Unit/Types.hs @@ -104,9 +104,9 @@ import GHC.Utils.Misc import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq +import Control.DeepSeq (NFData(..)) import Data.Data -import Data.List (sortBy ) +import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS diff --git a/GHC/Utils/Containers/Internal/StrictPair.hs b/GHC/Utils/Containers/Internal/StrictPair.hs --- a/GHC/Utils/Containers/Internal/StrictPair.hs +++ b/GHC/Utils/Containers/Internal/StrictPair.hs @@ -4,6 +4,11 @@ module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +default () + -- | The same as a regular Haskell pair, but -- -- @ diff --git a/GHC/Utils/Fingerprint.hs b/GHC/Utils/Fingerprint.hs --- a/GHC/Utils/Fingerprint.hs +++ b/GHC/Utils/Fingerprint.hs @@ -19,6 +19,7 @@ fingerprintFingerprints, fingerprintData, fingerprintString, + fingerprintStrings, getFileHash ) where @@ -43,3 +44,7 @@ fingerprintByteString :: BS.ByteString -> Fingerprint fingerprintByteString bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len + +-- See Note [Repeated -optP hashing] +fingerprintStrings :: [String] -> Fingerprint +fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs --- a/GHC/Utils/Outputable.hs +++ b/GHC/Utils/Outputable.hs @@ -1260,7 +1260,7 @@ data JoinPointHood = JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because - | NotJoinPoint -- synonym JoinArity is defined in Types.Basic + | NotJoinPoint -- synonym JoinArity is defined in Types.Basic) deriving( Eq ) isJoinPoint :: JoinPointHood -> Bool diff --git a/GHC/Utils/TmpFs.hs b/GHC/Utils/TmpFs.hs --- a/GHC/Utils/TmpFs.hs +++ b/GHC/Utils/TmpFs.hs @@ -377,18 +377,27 @@ This is ok, as the temporary directory used contains the pid (see getTempDir). -} + +manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO () +manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths +manyWithTrace logger phase act paths + = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths) + removeTmpDirs :: Logger -> [FilePath] -> IO () -removeTmpDirs logger ds - = traceCmd logger "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith logger removeDirectory) ds) +removeTmpDirs logger + = manyWithTrace logger "Deleting temp dirs" + (mapM_ (removeWith logger removeDirectory)) +removeTmpSubdirs :: Logger -> [FilePath] -> IO () +removeTmpSubdirs logger + = manyWithTrace logger "Deleting temp subdirs" + (mapM_ (removeWith logger removeDirectory)) + removeTmpFiles :: Logger -> [FilePath] -> IO () removeTmpFiles logger fs = warnNon $ - traceCmd logger "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith logger removeFile) deletees) + manyWithTrace logger "Deleting temp files" + (mapM_ (removeWith logger removeFile)) deletees where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source @@ -404,12 +413,6 @@ act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs - -removeTmpSubdirs :: Logger -> [FilePath] -> IO () -removeTmpSubdirs logger fs - = traceCmd logger "Deleting temp subdirs" - ("Deleting: " ++ unwords fs) - (mapM_ (removeWith logger removeDirectory) fs) removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO` diff --git a/cbits/genSym.c b/cbits/genSym.c --- a/cbits/genSym.c +++ b/cbits/genSym.c @@ -9,7 +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,9,0,0) + +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +// Unique64 patch was present in 9.10 and later +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) +// Unique64 patch was backported to 9.8.4 +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) +// Unique64 patch was backported to 9.6.7 +#define HAVE_UNIQUE64 1 +#endif + +#if !defined(HAVE_UNIQUE64) HsWord64 ghc_unique_counter64 = 0; #endif #if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.10.1 +Version: 9.10.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -109,7 +109,7 @@ deepseq >= 1.4 && < 1.6, directory >= 1 && < 1.4, process >= 1 && < 1.7, - bytestring >= 0.9 && < 0.13, + bytestring >= 0.11 && < 0.13, binary == 0.8.*, time >= 1.4 && < 1.13, containers >= 0.6.2.1 && < 0.8, @@ -121,9 +121,9 @@ exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.10.1, - ghc-heap == 9.10.1, - ghci == 9.10.1 + ghc-boot == 9.10.2, + ghc-heap == 9.10.2, + ghci == 9.10.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 @@ -414,6 +414,7 @@ GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap + GHC.Data.FlatBag GHC.Data.Graph.Base GHC.Data.Graph.Color GHC.Data.Graph.Collapse @@ -828,7 +829,7 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic - GHC.Types.BreakInfo + GHC.Types.Breakpoint GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State