ghc 9.10.1 → 9.10.2

raw patch · 150 files changed

+3452/−1340 lines, 150 filesdep ~bytestringdep ~ghc-bootdep ~ghc-heapPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: bytestring, ghc-boot, ghc-heap, ghci

API changes (from Hackage documentation)

Files

• GHC.hs +12/−7
• GHC/Builtin/Names.hs +7/−9
• GHC/Builtin/PrimOps.hs-boot +2/−1
• GHC/Builtin/Types.hs +142/−74
• GHC/Builtin/Types/Prim.hs +5/−2
• GHC/Builtin/primops.txt.pp +46/−16
• GHC/ByteCode/Asm.hs +16/−11
• GHC/ByteCode/Instr.hs +11/−4
• GHC/ByteCode/Linker.hs +53/−23
• GHC/ByteCode/Types.hs +12/−8
• GHC/Cmm/Dominators.hs +0/−1
• GHC/Cmm/Lexer.hs +2/−2
• GHC/Cmm/Opt.hs +18/−1
• GHC/Cmm/ThreadSanitizer.hs +1/−2
• GHC/CmmToAsm/AArch64.hs +1/−0
• GHC/CmmToAsm/AArch64/CodeGen.hs +298/−16
• GHC/CmmToAsm/AArch64/Instr.hs +60/−9
• GHC/CmmToAsm/AArch64/Ppr.hs +13/−3
• GHC/CmmToAsm/AArch64/Regs.hs +1/−0
• GHC/CmmToAsm/BlockLayout.hs +2/−3
• GHC/CmmToAsm/Instr.hs +7/−1
• GHC/CmmToAsm/Monad.hs +26/−0
• GHC/CmmToAsm/PPC.hs +1/−0
• GHC/CmmToAsm/PPC/CodeGen.hs +1/−1
• GHC/CmmToAsm/PPC/Instr.hs +8/−0
• GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−1
• GHC/CmmToAsm/Reg/Liveness.hs +5/−0
• GHC/CmmToAsm/X86.hs +1/−0
• GHC/CmmToAsm/X86/CodeGen.hs +11/−7
• GHC/CmmToAsm/X86/Instr.hs +12/−0
• GHC/CmmToLlvm.hs +9/−8
• GHC/Core/LateCC.hs +6/−2
• GHC/Core/LateCC/TopLevelBinds.hs +31/−9
• GHC/Core/LateCC/Types.hs +1/−1
• GHC/Core/Map/Type.hs +1/−1
• GHC/Core/Opt/Arity.hs +3/−3
• GHC/Core/Opt/ConstantFold.hs +15/−5
• GHC/Core/Opt/DmdAnal.hs +3/−3
• GHC/Core/Opt/OccurAnal.hs +144/−100
• GHC/Core/Opt/SetLevels.hs +46/−15
• GHC/Core/Opt/Simplify/Iteration.hs +27/−14
• GHC/Core/Opt/SpecConstr.hs +17/−2
• GHC/Core/Opt/Specialise.hs +2/−1
• GHC/Core/TyCo/Compare.hs +107/−48
• GHC/Core/TyCo/Ppr.hs +8/−7
• GHC/Core/TyCo/Rep.hs +19/−4
• GHC/Core/TyCo/Subst.hs +1/−1
• GHC/Core/Type.hs +2/−0
• GHC/Core/Unify.hs +1/−1
• GHC/Core/Utils.hs +1/−1
• GHC/CoreToStg/Prep.hs +165/−72
• GHC/Data/FlatBag.hs +129/−0
• GHC/Data/SmallArray.hs +57/−2
• GHC/Data/Word64Map/Strict.hs +0/−1
• GHC/Driver/CmdLine.hs +1/−1
• GHC/Driver/Config/Core/Opt/Simplify.hs +35/−0
• GHC/Driver/Config/CoreToStg/Prep.hs +3/−7
• GHC/Driver/Config/Diagnostic.hs +1/−1
• GHC/Driver/Config/StgToCmm.hs +8/−1
• GHC/Driver/DynFlags.hs +2/−0
• GHC/Driver/Errors/Ppr.hs +4/−4
• GHC/Driver/Flags.hs +5/−0
• GHC/Driver/Hooks.hs +0/−2
• GHC/Driver/Main.hs +2/−5
• GHC/Driver/Make.hs +29/−27
• GHC/Driver/Pipeline.hs +21/−21
• GHC/Driver/Pipeline/Execute.hs +9/−5
• GHC/Driver/Plugins.hs +6/−6
• GHC/Driver/Session.hs +57/−8
• GHC/Hs/Type.hs +47/−0
• GHC/Iface/Env.hs +2/−2
• GHC/Iface/Errors/Ppr.hs +1/−1
• GHC/Iface/Load.hs +0/−3
• GHC/Iface/Recomp/Flags.hs +18/−2
• GHC/Iface/Syntax.hs +1/−1
• GHC/Iface/Tidy.hs +5/−2
• GHC/Iface/Type.hs +1/−1
• GHC/Iface/Type.hs-boot +1/−1
• GHC/Linker/Loader.hs +34/−26
• GHC/Linker/MacOS.hs +2/−2
• GHC/Linker/Types.hs +54/−4
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Parser/PostProcess.hs +0/−1
• GHC/Platform.hs +1/−1
• GHC/Rename/Env.hs +25/−1
• GHC/Rename/Module.hs +2/−0
• GHC/Rename/Pat.hs +2/−41
• GHC/Runtime/Eval.hs +66/−58
• GHC/Runtime/Eval/Types.hs +11/−13
• GHC/Runtime/Interpreter.hs +84/−63
• GHC/Runtime/Interpreter/JS.hs +0/−3
• GHC/Runtime/Interpreter/Types.hs +3/−3
• GHC/Settings.hs +32/−1
• GHC/Settings/IO.hs +45/−9
• GHC/StgToByteCode.hs +50/−27
• GHC/StgToCmm/Config.hs +3/−0
• GHC/StgToCmm/Foreign.hs +68/−8
• GHC/StgToCmm/InfoTableProv.hs +3/−4
• GHC/StgToCmm/Prim.hs +4/−3
• GHC/StgToJS/Linker/Linker.hs +82/−8
• GHC/StgToJS/Linker/Utils.hs +1/−1
• GHC/StgToJS/Literal.hs +18/−1
• GHC/StgToJS/Prim.hs +1/−1
• GHC/StgToJS/Rts/Rts.hs +6/−1
• GHC/StgToJS/Types.hs +1/−1
• GHC/SysTools/Cpp.hs +57/−17
• GHC/SysTools/Tasks.hs +72/−26
• GHC/Tc/Errors.hs +5/−46
• GHC/Tc/Errors/Hole/Plugin.hs-boot +3/−0
• GHC/Tc/Errors/Ppr.hs +71/−15
• GHC/Tc/Errors/Types.hs +1/−2
• GHC/Tc/Gen/App.hs +6/−13
• GHC/Tc/Gen/Bind.hs +34/−12
• GHC/Tc/Gen/Head.hs +3/−41
• GHC/Tc/Gen/HsType.hs +24/−1
• GHC/Tc/Gen/Match.hs +35/−4
• GHC/Tc/Gen/Pat.hs +94/−39
• GHC/Tc/Instance/Family.hs +57/−1
• GHC/Tc/Module.hs +57/−11
• GHC/Tc/Solver/Equality.hs +11/−11
• GHC/Tc/Types.hs +4/−0
• GHC/Tc/Types/Constraint.hs +59/−23
• GHC/Tc/Types/Evidence.hs +13/−13
• GHC/Tc/Types/LclEnv.hs-boot +3/−0
• GHC/Tc/Utils/Env.hs +43/−1
• GHC/Tc/Utils/Instantiate.hs +87/−13
• GHC/Tc/Utils/Monad.hs +17/−1
• GHC/Tc/Utils/TcType.hs +16/−3
• GHC/Tc/Utils/Unify.hs +60/−60
• GHC/Tc/Zonk/Type.hs +4/−3
• GHC/ThToHs.hs +2/−1
• GHC/Types/BreakInfo.hs +0/−12
• GHC/Types/Breakpoint.hs +53/−0
• GHC/Types/Demand.hs +23/−13
• GHC/Types/Id.hs +21/−16
• GHC/Types/Id.hs-boot +0/−1
• GHC/Types/Id/Info.hs +16/−5
• GHC/Types/Id/Make.hs +14/−16
• GHC/Types/Name/Ppr.hs +2/−1
• GHC/Types/RepType.hs +3/−0
• GHC/Types/Var.hs +1/−1
• GHC/Types/Var.hs-boot +0/−6
• GHC/Unit/Types.hs +2/−2
• GHC/Utils/Containers/Internal/StrictPair.hs +5/−0
• GHC/Utils/Fingerprint.hs +5/−0
• GHC/Utils/Outputable.hs +1/−1
• GHC/Utils/TmpFs.hs +16/−13
• cbits/genSym.c +13/−1
• ghc.cabal +7/−6

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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 

@@ -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) _)

@@ -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 "<breakarray>"-                               <+> ppr index <+> text "<module>" <+> text "<cc>"+   ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)+                             = text "BRK_FUN" <+> text "<breakarray>"+                               <+> text "<tick_module>" <+> ppr tickx+                               <+> text "<info_module>" <+> ppr infox+                               <+> text "<cc>"   

@@ -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

@@ -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" <+>

@@ -23,7 +23,6 @@ import GHC.Prelude  import Data.Array.IArray-import Data.Foldable() import qualified Data.Tree as Tree  import Data.Word

@@ -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

@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -184,7 +184,7 @@     restore = blockFromList restore_nodes  -- | Mirrors __tsan_memory_order--- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>+-- <https://github.com/llvm/llvm-project/blob/main/compiler-rt/include/sanitizer/tsan_interface_atomic.h#L34> 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'-

@@ -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

@@ -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)

@@ -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.<cond>      -- 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"

@@ -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"

@@ -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.

@@ -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

@@ -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.

@@ -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; \<block_l1>@     -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -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

@@ -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)

@@ -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.

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ->

@@ -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 = <scc 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 ->+        <scc f> 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

@@ -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

@@ -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

@@ -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  {- ************************************************************************

@@ -2660,6 +2660,10 @@      inline f_ty (f a b c) = <f's unfolding> a b c   (if f has an unfolding, EVEN if it's a loop breaker) +  Additionally the rule looks through ticks/casts as well (#24808):+      inline f_ty (f a b c |> co) = <f's unfolding> a b c |> co+      inline f_ty <tick> ( f a b c ) = <tick> <f's unfolding> a b c+   It's important to allow the argument to 'inline' to have args itself   (a) because its more forgiving to allow the programmer to write       either  inline f a b c@@ -2672,11 +2676,17 @@ -}  match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_inline (Type _ : e : _)-  | (Var f, args1) <- collectArgs e,-    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)-             -- Ignore the IdUnfoldingFun here!-  = Just (mkApps unf args1)+match_inline (Type _ : e : _) = go e+  -- Maybe Monad ahead:+  where+    go (Var f)      = -- Ignore the IdUnfoldingFun here!+                      (maybeUnfoldingTemplate (realIdUnfolding f))+    go (App f a)    = do { f' <- go f; pure $ App f' a }+    -- inline (f |> co)+    go (Cast e co)  = do { app <- go e; pure (Cast app co) }+    -- inline (<tick> f)+    go (Tick t e)   = do { app <- go e; pure (Tick t app) }+    go _            = Nothing  match_inline _ = Nothing 

@@ -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:

@@ -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 

@@ -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. -}

@@ -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 }

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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 () 

@@ -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

@@ -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 <binds> in rhs       where <binds> 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)

@@ -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)

@@ -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

@@ -248,4 +248,3 @@     ) where  import GHC.Data.Word64Map.Strict.Internal-import Prelude ()

@@ -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

@@ -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.+-}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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) $

@@ -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  

@@ -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  ]

@@ -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 ()

@@ -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,

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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,

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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)           }

@@ -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.     --

@@ -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

@@ -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

@@ -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(..) )

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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+  }

@@ -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 "<unknown>")+    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 "<unknown>")+        -- 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

@@ -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         } 

@@ -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

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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<string>} */ 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

@@ -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"

@@ -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

@@ -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 -------------------------

@@ -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 $

@@ -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

@@ -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

@@ -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+                  <vendor> 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

@@ -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`. -}  -----------------------

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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]