ghc 9.8.1 → 9.8.2

raw patch · 94 files changed

+1772/−857 lines, 94 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

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

API changes (from Hackage documentation)

Files

• CodeGen.Platform.h +33/−0
• GHC.hs +1/−3
• GHC/Builtin/primops.txt.pp +15/−0
• GHC/Cmm.hs +2/−3
• GHC/Cmm/CallConv.hs +4/−2
• GHC/Cmm/Lexer.hs +2/−2
• GHC/CmmToAsm/Ppr.hs +3/−2
• GHC/CmmToAsm/Wasm/FromCmm.hs +1/−1
• GHC/CmmToAsm/X86/CodeGen.hs +0/−23
• GHC/CmmToAsm/X86/Instr.hs +4/−2
• GHC/CmmToLlvm/CodeGen.hs +38/−19
• GHC/CmmToLlvm/Data.hs +1/−0
• GHC/Core.hs +34/−21
• GHC/Core/Class.hs +45/−15
• GHC/Core/Coercion/Axiom.hs +27/−17
• GHC/Core/Opt/CSE.hs +3/−3
• GHC/Core/Opt/CprAnal.hs +40/−4
• GHC/Core/Opt/FloatIn.hs +1/−1
• GHC/Core/Opt/Pipeline.hs +1/−1
• GHC/Core/Opt/Simplify/Iteration.hs +85/−61
• GHC/Core/Opt/Simplify/Utils.hs +4/−3
• GHC/Core/Opt/SpecConstr.hs +7/−14
• GHC/Core/Opt/Specialise.hs +2/−5
• GHC/Core/Predicate.hs +8/−1
• GHC/Core/Subst.hs +2/−0
• GHC/Core/Unify.hs +5/−2
• GHC/Data/Bag.hs +7/−0
• GHC/Data/Graph/Directed.hs +34/−29
• GHC/Driver/Config/StgToCmm.hs +2/−0
• GHC/Driver/DynFlags.hs +2/−1
• GHC/Driver/Flags.hs +6/−1
• GHC/Driver/GenerateCgIPEStub.hs +203/−95
• GHC/Driver/Main.hs +31/−10
• GHC/Driver/Make.hs +28/−24
• GHC/Driver/Pipeline.hs +12/−1
• GHC/Driver/Pipeline/Execute.hs +3/−1
• GHC/Driver/Session.hs +125/−122
• GHC/HsToCore/Binds.hs +13/−2
• GHC/HsToCore/Foreign/C.hs +1/−1
• GHC/Iface/Errors/Ppr.hs +4/−3
• GHC/Iface/Errors/Types.hs +2/−2
• GHC/IfaceToCore.hs +1/−1
• GHC/Linker/Dynamic.hs +9/−2
• GHC/Llvm/Ppr.hs +1/−10
• GHC/Llvm/Syntax.hs +0/−3
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +3/−3
• GHC/Platform/Wasm32.hs +2/−3
• GHC/Rename/Doc.hs +1/−1
• GHC/Rename/Env.hs +19/−16
• GHC/Rename/Module.hs +5/−4
• GHC/Rename/Names.hs +49/−10
• GHC/Rename/Utils.hs +1/−1
• GHC/Runtime/Heap/Layout.hs +3/−3
• GHC/Settings.hs +1/−0
• GHC/Settings/IO.hs +2/−0
• GHC/Stg/CSE.hs +2/−2
• GHC/Stg/Debug.hs +2/−2
• GHC/StgToCmm/Bind.hs +19/−5
• GHC/StgToCmm/CgUtils.hs +8/−6
• GHC/StgToCmm/Closure.hs +20/−18
• GHC/StgToCmm/Config.hs +3/−2
• GHC/StgToCmm/Expr.hs +13/−35
• GHC/StgToCmm/Heap.hs +1/−1
• GHC/StgToCmm/Monad.hs +3/−1
• GHC/StgToCmm/Prim.hs +23/−10
• GHC/StgToCmm/Prof.hs +13/−10
• GHC/StgToCmm/Sequel.hs +12/−2
• GHC/StgToCmm/Utils.hs +78/−16
• GHC/StgToJS/Linker/Utils.hs +29/−23
• GHC/Tc/Deriv/Generate.hs +3/−1
• GHC/Tc/Errors/Ppr.hs +63/−6
• GHC/Tc/Errors/Types.hs +44/−3
• GHC/Tc/Gen/HsType.hs +110/−13
• GHC/Tc/Gen/Splice.hs +8/−2
• GHC/Tc/Solver/Equality.hs +10/−4
• GHC/Tc/TyCl.hs +142/−52
• GHC/Tc/TyCl/Build.hs +0/−1
• GHC/Tc/TyCl/Instance.hs +22/−17
• GHC/Tc/TyCl/Utils.hs +0/−1
• GHC/Tc/Validity.hs +90/−29
• GHC/Tc/Zonk/Type.hs +1/−1
• GHC/Types/Avail.hs +1/−1
• GHC/Types/Error/Codes.hs +1/−0
• GHC/Types/Hint.hs +3/−0
• GHC/Types/Hint/Ppr.hs +3/−0
• GHC/Types/Name/Reader.hs +43/−14
• GHC/Unit/Finder.hs +1/−1
• GHC/Unit/Finder/Types.hs +1/−1
• GHC/Unit/Module/ModIface.hs +1/−5
• GHC/Unit/State.hs +37/−11
• GHC/Utils/Outputable.hs +10/−0
• MachRegs.h +8/−1
• ghc.cabal +4/−4

@@ -203,6 +203,39 @@ # define d29 61 # define d30 62 # define d31 63++# define q0 32+# define q1 33+# define q2 34+# define q3 35+# define q4 36+# define q5 37+# define q6 38+# define q7 39+# define q8 40+# define q9 41+# define q10 42+# define q11 43+# define q12 44+# define q13 45+# define q14 46+# define q15 47+# define q16 48+# define q17 49+# define q18 50+# define q19 51+# define q20 52+# define q21 53+# define q22 54+# define q23 55+# define q24 56+# define q25 57+# define q26 58+# define q27 59+# define q28 60+# define q29 61+# define q30 62+# define q31 63 #endif  # if defined(MACHREGS_darwin)

@@ -1518,9 +1518,7 @@ modInfoModBreaks = minf_modBreaks  isDictonaryId :: Id -> Bool-isDictonaryId id-  = case tcSplitSigmaTy (idType id) of {-      (_tvs, _theta, tau) -> isDictTy tau }+isDictonaryId id = isDictTy (idType id)  -- | Looks up a global name: that is, any top-level name in any -- visible module.  Unlike 'lookupName', lookupGlobalName does not use

@@ -3826,10 +3826,25 @@      more complicated settings, e.g. converting a list of newtypes to a list of      concrete types. +     When used in conversions involving a newtype wrapper,+     make sure the newtype constructor is in scope.+      This function is representation-polymorphic, but the      'RuntimeRep' type argument is marked as 'Inferred', meaning      that it is not available for visible type application. This means      the typechecker will accept @'coerce' \@'Int' \@Age 42@.++     === __Examples__++     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)+     >>> coerce (Age 42) :: TTL+     TTL 42+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL+     TTL 43+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]+     [TTL 43,TTL 25]+    }  ------------------------------------------------------------------------

@@ -229,16 +229,15 @@         -- place to convey this information from the code generator to         -- where we build the static closures in         -- GHC.Cmm.Info.Build.doSRTs.-    } deriving Eq+    } deriving (Eq, Ord)  instance OutputableP Platform CmmInfoTable where     pdoc = pprInfoTable - data ProfilingInfo   = NoProfilingInfo   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc-  deriving Eq+  deriving (Eq, Ord) ----------------------------------------------------------------------------- --              Static Data -----------------------------------------------------------------------------

@@ -193,8 +193,10 @@  realXmmRegNos :: Platform -> [Int] realXmmRegNos platform-    | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))-    | otherwise              = []+    | isSse2Enabled platform || platformArch platform == ArchAArch64+    = regList (pc_MAX_Real_XMM_REG (platformConstants platform))+    | otherwise+    = []  regList :: Int -> [Int] regList n = [1 .. n]

@@ -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.8.1-src/ghc-9.8.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer (    CmmToken(..), cmmlex,   ) where@@ -386,7 +386,7 @@   , (0,alex_action_20)   ] -{-# LINE 134 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 134 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -246,9 +246,10 @@         panic "PprBase.pprGNUSectionHeader: unknown section type"     flags = case t of       Text-        | OSMinGW32 <- platformOS platform+        | OSMinGW32 <- platformOS platform, splitSections                     -> text ",\"xr\""-        | otherwise -> text ",\"ax\"," <> sectionType platform "progbits"+        | splitSections+                    -> text ",\"ax\"," <> sectionType platform "progbits"       CString         | OSMinGW32 <- platformOS platform                     -> empty

@@ -883,7 +883,7 @@       pure $         SomeWasmExpr ty_word $           WasmExpr $-            WasmSymConst "stg_EAGER_BLACKHOLE_info"+            WasmSymConst "__stg_EAGER_BLACKHOLE_info"     GCEnter1 -> do       onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]       pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"

@@ -3230,32 +3230,9 @@   (y_reg, y_code) <- getNonClobberedReg y   (z_reg, z_code) <- getNonClobberedReg z   x_code <- getAnyReg x-  y_tmp <- getNewRegNat rep-  z_tmp <- getNewRegNat rep   let      fma213 = FMA3 rep signs FMA213      code dst-         | dst == y_reg-         , dst == z_reg-         = y_code `appOL`-           unitOL (MOV rep (OpReg y_reg) (OpReg y_tmp)) `appOL`-           z_code `appOL`-           unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL`-           x_code dst `snocOL`-           fma213 (OpReg z_tmp) y_tmp dst-        | dst == y_reg-        = y_code `appOL`-          unitOL (MOV rep (OpReg y_reg) (OpReg z_tmp)) `appOL`-          z_code `appOL`-          x_code dst `snocOL`-          fma213 (OpReg z_reg) y_tmp dst-        | dst == z_reg-        = y_code `appOL`-          z_code `appOL`-          unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL`-          x_code dst `snocOL`-          fma213 (OpReg z_tmp) y_reg dst-        | otherwise         = y_code `appOL`           z_code `appOL`           x_code dst `snocOL`

@@ -275,7 +275,8 @@          -- | FMA3 fused multiply-add operations.         | FMA3         Format FMASign FMAPermutation Operand Reg Reg-          -- src1 (r/m), src2 (r), dst (r)+          -- src3 (r/m), src2 (r), dst/src1 (r)+          -- The is exactly reversed from how intel lists the arguments.          -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands         -- are  Operand Reg.@@ -356,6 +357,7 @@         | OpImm  Imm            -- immediate value         | OpAddr AddrMode       -- memory reference +-- NB: As of 2023 we only use the FMA213 permutation. data FMAPermutation = FMA132 | FMA213 | FMA231  -- | Returns which registers are read and written as a (read, written)@@ -443,7 +445,7 @@     PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]     PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] -    FMA3 _ _ _ src1 src2 dst -> usageFMA src1 src2 dst+    FMA3 _ _ _ src3 src2 dst -> usageFMA src3 src2 dst      -- note: might be a better way to do this     PREFETCH _  _ src -> mkRU (use_R src []) []

@@ -12,6 +12,7 @@ import GHC.Platform.Regs ( activeStgRegs )  import GHC.Llvm+import GHC.Llvm.Types import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs@@ -1787,31 +1788,49 @@                     pprPanic "isSMulOK: Not bit type! " $                         lparen <> ppr word <> rparen -        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered"                        ++ "with two arguments! (" ++ show op ++ ")" -genMachOp_slow _opt op [x, y, z] = case op of-    MO_FMA var _ -> triLlvmOp getVarType (FMAOp var)-    _            -> panicOp-    where-        triLlvmOp ty op = do-          platform <- getPlatform-          runExprData $ do-            vx <- exprToVarW x-            vy <- exprToVarW y-            vz <- exprToVarW z--            if | getVarType vx == getVarType vy-               , getVarType vx == getVarType vz-               -> doExprW (ty vx) $ op vx vy vz-               | otherwise-               -> pprPanic "triLlvmOp types" (pdoc platform x $$ pdoc platform y $$ pdoc platform z)-        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"-                       ++ "with three arguments! (" ++ show op ++ ")"+genMachOp_slow _opt op [x, y, z] = do+  platform <- getPlatform+  let+    neg x = CmmMachOp (MO_F_Neg (cmmExprWidth platform x)) [x]+    panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"+                   ++ "with three arguments! (" ++ show op ++ ")"+  case op of+    MO_FMA var _ ->+      case var of+        -- LLVM only has the fmadd variant.+        FMAdd   -> genFmaOp x y z+        -- Other fused multiply-add operations are implemented in terms of fmadd+        -- This is sound: it does not lose any precision.+        FMSub   -> genFmaOp x y (neg z)+        FNMAdd  -> genFmaOp (neg x) y z+        FNMSub  -> genFmaOp (neg x) y (neg z)+    _ -> panicOp  -- More than three expressions, invalid! genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!" +-- | Generate code for a fused multiply-add operation.+genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData+genFmaOp x y z = runExprData $ do+  vx <- exprToVarW x+  vy <- exprToVarW y+  vz <- exprToVarW z+  let tx = getVarType vx+      ty = getVarType vy+      tz = getVarType vz+  Panic.massertPpr+    (tx == ty && tx == tz)+    (vcat [ text "fma: mismatched arg types"+          , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ])+  let fname = case tx of+        LMFloat  -> fsLit "llvm.fma.f32"+        LMDouble -> fsLit "llvm.fma.f64"+        _ -> pprPanic "fma: type not LMFloat or LMDouble" (ppLlvmType tx)+  fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]+  doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind]  -- | Handle CmmLoad expression. genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData

@@ -89,6 +89,7 @@         align          = case sec of                             Section CString _ -> if (platformArch platform == ArchS390X)                                                     then Just 2 else Just 1+                            Section Data _    -> Just $ platformWordSizeInBytes platform                             _                 -> Nothing         const          = if sectionProtection sec == ReadOnlySection                             then Constant else Global

@@ -155,7 +155,7 @@ --      f_1 x_2 = let f_3 x_4 = x_4 + 1 --                in f_3 (x_2 - 2) -- @---    But see Note [Shadowing] below.+--    But see Note [Shadowing in Core] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --    type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names.@@ -313,26 +313,6 @@   deriving Data  {--Note [Shadowing]-~~~~~~~~~~~~~~~~-While various passes attempt to rename on-the-fly in a manner that-avoids "shadowing" (thereby simplifying downstream optimizations),-neither the simplifier nor any other pass GUARANTEES that shadowing is-avoided. Thus, all passes SHOULD work fine even in the presence of-arbitrary shadowing in their inputs.--In particular, scrutinee variables `x` in expressions of the form-`Case e x t` are often renamed to variables with a prefix-"wild_". These "wild" variables may appear in the body of the-case-expression, and further, may be shadowed within the body.--So the Unique in a Var is not really unique at all.  Still, it's very-useful to give a constant-time equality/ordering for Vars, and to give-a key that can be used to make sets of Vars (VarSet), or mappings from-Vars to other things (VarEnv).   Moreover, if you do want to eliminate-shadowing, you can give a new Unique to an Id without changing its-printable name, which makes debugging easier.- Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals.@@ -363,6 +343,39 @@   \(c :: Age~#Int) (d::Int). d |> (sym c) Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c).++Note [Shadowing in Core]+~~~~~~~~~~~~~~~~~~~~~~~~+You might wonder if there is an invariant that a Core expression has no+"shadowing".  For example, is this illegal?+     \x. \x. blah     -- x is shadowed+Answer; no!  Core does /not/ have a no-shadowing invariant.++Neither the simplifier nor any other pass GUARANTEES that shadowing is+avoided. Thus, all passes SHOULD work fine even in the presence of+arbitrary shadowing in their inputs.++So the Unique in a Var is not really unique at all.  Still, it's very+useful to give a constant-time equality/ordering for Vars, and to give+a key that can be used to make sets of Vars (VarSet), or mappings from+Vars to other things (VarEnv).   Moreover, if you do want to eliminate+shadowing, you can give a new Unique to an Id without changing its+printable name, which makes debugging easier.++It would in many ways be easier to have a no-shadowing invariant.  And the+Simplifier does its best to clone variables that are shadowed.  But it is+extremely difficult to GUARANTEE it:++* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques+  that are locally-unique (enough for the purpose) but not globally unique.+  It is convenient not to have to plumb a unique supply to these functions.++* It is very difficult for the Simplifier to gurantee a no-shadowing result.+  See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration.++* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE++* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr  Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -8,7 +8,7 @@ module GHC.Core.Class (         Class,         ClassOpItem,-        ClassATItem(..), ATValidityInfo(..),+        ClassATItem(..), TyFamEqnValidityInfo(..),         ClassMinimalDef,         DefMethInfo, pprDefMethInfo, @@ -34,6 +34,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc+import GHC.Types.Var.Set import GHC.Utils.Outputable import GHC.Data.BooleanFormula (BooleanFormula, mkTrue) @@ -96,20 +97,44 @@  data ClassATItem   = ATI TyCon         -- See Note [Associated type tyvar names]-        (Maybe (Type, ATValidityInfo))-                      -- Default associated type (if any) from this template-                      -- Note [Associated type defaults]+        (Maybe (Type, TyFamEqnValidityInfo))+          -- ^ Default associated type (if any) from this template.+          --+          -- As per Note [Associated type defaults], the Type has been renamed+          -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses+          -- the original user-written type variables. --- | Information about an associated type family default implementation. This--- is used solely for validity checking.+-- | Information about a type family equation, used for validity checking+-- of closed type family equations and associated type family default equations.+--+-- This type exists to delay validity-checking after typechecking type declaration+-- groups, to avoid cyclic evaluation inside the typechecking knot.+-- -- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".-data ATValidityInfo-  = NoATVI               -- Used for associated type families that are imported-                         -- from another module, for which we don't need to-                         -- perform any validity checking.+data TyFamEqnValidityInfo+  -- | Used for equations which don't need any validity checking,+  -- for example equations imported from another module.+  = NoVI -  | ATVI SrcSpan [Type]  -- Used for locally defined associated type families.-                         -- The [Type] are the LHS patterns.+  -- | Information necessary for validity checking of a type family equation.+  | VI+    { vi_loc :: SrcSpan+    , vi_qtvs :: [TcTyVar]+      -- ^ LHS quantified type variables+    , vi_non_user_tvs :: TyVarSet+      -- ^ non-user-written type variables (for error message reporting)+      --+      -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@+      -- introduces the kind variable @k@ for the kind of @a@. See #23734.+    , vi_pats :: [Type]+      -- ^ LHS patterns+    , vi_rhs :: Type+      -- ^ RHS of the equation+      --+      -- NB: for associated type family default declarations, this is the RHS+      -- *before* applying the substitution from+      -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl.+    }  type ClassMinimalDef = BooleanFormula Name -- Required methods @@ -166,9 +191,14 @@  * HOWEVER, in the internal ClassATItem we rename the RHS to match the    tyConTyVars of the family TyCon.  So in the example above we'd get    a ClassATItem of-        ATI F ((x,a) -> b)-   So the tyConTyVars of the family TyCon bind the free vars of-   the default Type rhs++        ATI F (Just ((x,a) -> b, validity_info)++   That is, the type stored in the first component of the pair has been+   renamed to use the class type variables. On the other hand, the+   TyFamEqnValidityInfo, used for validity checking of the type family equation+   (considered as a free-standing equation) uses the original types, e.g.+   involving the type variables 'p', 'q', 'r'.  The @mkClass@ function fills in the indirect superclasses. 

@@ -236,25 +236,35 @@          -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.     } +-- | A branch of a coercion axiom, which provides the evidence for+-- unwrapping a newtype or a type-family reduction step using a single equation. data CoAxBranch   = CoAxBranch-    { cab_loc      :: SrcSpan       -- Location of the defining equation-                                    -- See Note [CoAxiom locations]-    , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh-                                    -- See Note [CoAxBranch type variables]-    , cab_eta_tvs  :: [TyVar]       -- Eta-reduced tyvars-                                    -- cab_tvs and cab_lhs may be eta-reduced; see-                                    -- Note [Eta reduction for data families]-    , cab_cvs      :: [CoVar]       -- Bound coercion variables-                                    -- Always empty, for now.-                                    -- See Note [Constraints in patterns]-                                    -- in GHC.Tc.TyCl-    , cab_roles    :: [Role]        -- See Note [CoAxBranch roles]-    , cab_lhs      :: [Type]        -- Type patterns to match against-    , cab_rhs      :: Type          -- Right-hand side of the equality-                                    -- See Note [CoAxioms are homogeneous]-    , cab_incomps  :: [CoAxBranch]  -- The previous incompatible branches-                                    -- See Note [Storing compatibility]+    { cab_loc      :: SrcSpan+        -- ^ Location of the defining equation+        -- See Note [CoAxiom locations]+    , cab_tvs      :: [TyVar]+       -- ^ Bound type variables; not necessarily fresh+       -- See Note [CoAxBranch type variables]+    , cab_eta_tvs  :: [TyVar]+       -- ^ Eta-reduced tyvars+       -- cab_tvs and cab_lhs may be eta-reduced; see+       -- Note [Eta reduction for data families]+    , cab_cvs      :: [CoVar]+       -- ^ Bound coercion variables+       -- Always empty, for now.+       -- See Note [Constraints in patterns]+       -- in GHC.Tc.TyCl+    , cab_roles    :: [Role]+       -- ^ See Note [CoAxBranch roles]+    , cab_lhs      :: [Type]+       -- ^ Type patterns to match against+    , cab_rhs      :: Type+       -- ^ Right-hand side of the equality+       -- See Note [CoAxioms are homogeneous]+    , cab_incomps  :: [CoAxBranch]+       -- ^ The previous incompatible branches+       -- See Note [Storing compatibility]     }   deriving Data.Data 

@@ -53,8 +53,8 @@ reverse mapping.  -Note [Shadowing]-~~~~~~~~~~~~~~~~+Note [Shadowing in CSE]+~~~~~~~~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider         f = \x -> let y = x+x in@@ -900,7 +900,7 @@ extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }  -- | Add clones to the substitution to deal with shadowing.  See--- Note [Shadowing] for more details.  You should call this whenever+-- Note [Shadowing in CSE] for more details.  You should call this whenever -- you go under a binder. addBinder :: CSEnv -> Var -> (CSEnv, Var) addBinder cse v = (cse { cs_subst = sub' }, v')

@@ -35,7 +35,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) )  import Data.List ( mapAccumL )@@ -271,11 +270,11 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs)   = (rhs_ty, Alt con bndrs rhs')   where+    ids = filter isId bndrs     env_alt       | DataAlt dc <- con-      , let ids = filter isId bndrs       , CprType arity cpr <- scrut_ty-      , assert (arity == 0 ) True+      , arity == 0 -- See Note [Dead code may contain type confusions]       = case unpackConFieldsCpr dc cpr of           AllFieldsSame field_cpr             | let sig = mkCprSig 0 field_cpr@@ -284,7 +283,7 @@             | let sigs = zipWith (mkCprSig . idArity) ids field_cprs             -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)       | otherwise-      = env+      = extendSigEnvAllSame env ids topCprSig     (rhs_ty, rhs') = cprAnal env_alt rhs  --@@ -431,6 +430,43 @@             (id', rhs', env') = cprAnalBind env id rhs  {-+Note [Dead code may contain type confusions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In T23862, we have a nested case match that looks like this++  data CheckSingleton (check :: Bool) where+    Checked :: CheckSingleton True+    Unchecked :: CheckSingleton False+  data family Result (check :: Bool) a+  data instance Result True a = CheckedResult a+  newtype instance Result True a = UncheckedResult a++  case m () of Checked co1 ->+    case m () of Unchecked co2 ->+      case ((\_ -> True)+             |> .. UncheckedResult ..+             |> sym co2+             |> co1) :: Result True (Bool -> Bool) of+        CheckedResult f -> CheckedResult (f True)++Clearly, the innermost case is dead code, because the `Checked` and `Unchecked`+cases are apart.+However, both constructors introduce mutually contradictory coercions `co1` and+`co2` along which GHC generates a type confusion:++  1. (\_ -> True) :: Bool -> Bool+  2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool)+  3. |> ... sym co1 ... :: Result check (Bool -> Bool)+  4. |> ... co2 ... :: Result True (Bool -> Bool)++Note that we started with a function, injected into `Result` via a newtype+instance and then match on it with a datatype instance.++We have to handle this case gracefully in `cprAnalAlt`, where for the innermost+case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that+abstracts the function `(\_ -> True)` with arity 1.+In this case, don't pretend we know anything about the fields of `CheckedResult`!+ Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider:

@@ -306,7 +306,7 @@        (y:ys) -> ...(let x = y+1 in x)...        [] -> blah because the y is captured.  This doesn't happen much, because shadowing is-rare, but it did happen in #22662.+rare (see Note [Shadowing in Core]), but it did happen in #22662.  One solution would be to clone as we go.  But a simpler one is this: 

@@ -309,7 +309,7 @@            [ CoreLiberateCase, simplify "post-liberate-case" ],            -- Run the simplifier after LiberateCase to vastly            -- reduce the possibility of shadowing-           -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr+           -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr          runWhen spec_constr $ CoreDoPasses            [ CoreDoSpecConstr, simplify "post-spec-constr"],

@@ -119,14 +119,6 @@    The returned floats and env both have an in-scope set, and they are    guaranteed to be the same. --Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.-- Eta expansion ~~~~~~~~~~~~~~ For eta expansion, we want to catch things like@@ -262,7 +254,7 @@   = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0         ; let new_bndrs = map sndOf3 triples         ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->-            go env triples+                                go env triples         ; return (mkRecFloats rec_floats, env2) }   where     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))@@ -303,10 +295,12 @@   | otherwise   = case bind_cxt of       BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $-                             simplJoinBind env is_rec cont old_bndr new_bndr rhs env+                             simplJoinBind is_rec cont+                                           (old_bndr,env) (new_bndr,env) (rhs,env)        BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $-                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env+                               simplLazyBind top_lvl is_rec+                                             (old_bndr,env) (new_bndr,env) (rhs,env)  simplTrace :: String -> SDoc -> SimplM a -> SimplM a simplTrace herald doc thing_inside = do@@ -316,19 +310,16 @@     else thing_inside  ---------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId+simplLazyBind :: TopLevelFlag -> RecFlag+              -> (InId, SimplEnv)       -- InBinder, and static env for its unfolding (if any)+              -> (OutId, SimplEnv)      -- OutBinder, and SimplEnv after simplifying that binder                                         -- The OutId has IdInfo (notably RULES),                                         -- except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> (InExpr, SimplEnv)     -- The RHS and its static environment               -> SimplM (SimplFloats, SimplEnv)--- Precondition: the OutId is already in the InScopeSet of the incoming 'env'--- Precondition: not a JoinId+-- Precondition: Ids only, no TyVars; not a JoinId -- Precondition: rhs obeys the let-can-float invariant-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)   = assert (isId bndr )     assertPpr (not (isJoinId bndr)) (ppr bndr) $     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $@@ -379,24 +370,23 @@                         ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds                         ; return (poly_floats, body3) } -        ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- rebuildLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'+        ; let env1 = env `setInScopeFromF` rhs_floats+        ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)         ; return (rhs_floats `addFloats` bind_float, env2) }  ---------------------------simplJoinBind :: SimplEnv-              -> RecFlag+simplJoinBind :: RecFlag               -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env+              -> (InId, SimplEnv)       -- InBinder, with static env for its unfolding+              -> (OutId, SimplEnv)      -- OutBinder; SimplEnv has the binder in scope+                                        -- The OutId has IdInfo, except arity, unfolding+              -> (InExpr, SimplEnv)     -- The right hand side and its env               -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se+simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se)   = do  { let rhs_env = rhs_se `setInScopeFromE` env         ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }+        ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) }  -------------------------- simplAuxBind :: SimplEnv@@ -407,7 +397,7 @@ -- auxiliary bindings, notably in knownCon. -- -- The binder comes from a case expression (case binder or alternative)--- and so does not have rules, inline pragmas etc.+-- and so does not have rules, unfolding, inline pragmas etc. -- -- Precondition: rhs satisfies the let-can-float invariant @@ -436,8 +426,8 @@            -- Simplify the binder and complete the binding         ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr-        ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)-                                             bndr new_bndr rhs1+        ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (new_bndr, rhs1, env1)          ; return (rhs_floats `addFloats` bind_float, env2) } @@ -843,7 +833,7 @@         ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1           -- Technically we should extend the in-scope set in 'env' with           -- the 'floats' from prepareRHS; but they are all fresh, so there is-          -- no danger of introducing name shadowig in eta expansion+          -- no danger of introducing name shadowing in eta expansion          ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2 @@ -917,11 +907,11 @@ Nor does it do the atomic-argument thing -} -completeBind :: SimplEnv-             -> BindContext-             -> InId           -- Old binder-             -> OutId          -- New binder; can be a JoinId-             -> OutExpr        -- New RHS+completeBind :: BindContext+             -> (InId, SimplEnv)           -- Old binder, and the static envt in which to simplify+                                           --   its stable unfolding (if any)+             -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId.+                                           -- And the SimplEnv with that OutId in scope.              -> SimplM (SimplFloats, SimplEnv) -- completeBind may choose to do its work --      * by extending the substitution (e.g. let x = y in ...)@@ -929,7 +919,7 @@ -- -- Binder /can/ be a JoinId -- Precondition: rhs obeys the let-can-float invariant-completeBind env bind_cxt old_bndr new_bndr new_rhs+completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)  | isCoVar old_bndr  = case new_rhs of      Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)@@ -945,9 +935,10 @@          -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils       ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs -        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr-                         eta_rhs (idType new_bndr) new_arity old_unf+        -- Simplify the unfolding; see Note [Environment for simplLetUnfolding]+      ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env)+                            bind_cxt old_bndr+                            eta_rhs (idType new_bndr) new_arity old_unf        ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding         -- See Note [In-scope set as a substitution]@@ -1064,7 +1055,37 @@ unfolding because it's too big. Hence the belt-and-braces `orElse` in the defn of unf_rhs.  The Nothing case probably never happens. +Note [Environment for simplLetUnfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be rather careful about the static environment in which+we simplify a stable unfolding.  Consider (#24242): +  f x = let y_Xb = ... in+        let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in+         ...++Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen;+see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier].+This is perfectly fine. The `y_Xb` in the stable unfolding of the non-+recursive binding for `step1` refers, of course, to `let y_Xb = ....`.+When simplifying the binder `step1_Xb` we'll give it a new unique, and+extend the static environment with [Xb :-> step1_Xc], say.++But when simplifying step1's stable unfolding, we must use static environment+/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps+[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc].++That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping+track of the right environment for the unfolding of that InId.  See the type+of `simplLazyBind`, `simplJoinBind`, `completeBind`.++This only matters when we have+  - A non-recursive binding for f+  - has a stable unfolding+  - and that unfolding mentions a variable y+  - that has the same unique as f.+So triggering  a bug here is really hard!+ ************************************************************************ *                                                                      * \subsection[Simplify-simplExpr]{The main function: simplExpr}@@ -1524,7 +1545,7 @@  completeBindX :: SimplEnv               -> FromWhat-              -> InId -> OutExpr   -- Bind this Id to this (simplified) expression+              -> InId -> OutExpr   -- Non-recursively bind this Id to this (simplified) expression                                    -- (the let-can-float invariant may not be satisfied)               -> InExpr            -- In this body               -> SimplCont         -- Consumed by this continuation@@ -1554,14 +1575,14 @@               -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',               -- because this is simplNonRecX, so bndr is not in scope in the RHS. -        ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)-                                             (BC_Let NotTopLevel NonRecursive)-                                             bndr bndr2 rhs1+        ; let env3 = env2 `setInScopeFromF` rhs_floats+        ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (bndr2, rhs1, env3)               -- Must pass env1 to completeBind in case simplBinder had to clone,               -- and extended the substitution with [bndr :-> new_bndr]          -- Simplify the body-        ; (body_floats, body') <- simplNonRecBody env2 from_what body cont+        ; (body_floats, body') <- simplNonRecBody env4 from_what body cont          ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats         ; return ( all_floats, body' ) }@@ -1776,10 +1797,11 @@ ------------------ simplNonRecE :: SimplEnv              -> FromWhat-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> InExpr                  -- Body of the let/lambda+             -> InId               -- The binder, always an Id+                                   -- Never a join point+                                   -- The static env for its unfolding (if any) is the first parameter+             -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)+             -> InExpr             -- Body of the let/lambda              -> SimplCont              -> SimplM (SimplFloats, OutExpr) @@ -1808,8 +1830,8 @@   | otherwise  -- Evaluate RHS lazily   = do { (env1, bndr1)    <- simplNonRecBndr env bndr        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)-       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive-                                           bndr bndr2 rhs rhs_se+       ; (floats1, env3)  <- simplLazyBind NotTopLevel NonRecursive+                                           (bndr,env) (bndr2,env2) (rhs,rhs_se)        ; (floats2, expr') <- simplNonRecBody env3 from_what body cont        ; return (floats1 `addFloats` floats2, expr') } @@ -1935,7 +1957,7 @@               res_ty = contResultType cont         ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty         ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)-        ; (floats1, env3)  <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env+        ; (floats1, env3)  <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)         ; (floats2, body') <- simplExprF env3 body cont         ; return (floats1 `addFloats` floats2, body') } @@ -2275,7 +2297,7 @@                (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty                           , sc_dup = Simplified                           , sc_cont = cont })-                -- Note [Shadowing]+                -- Note [Shadowing in the Simplifier]    -- Lazy arguments   | otherwise@@ -2408,10 +2430,10 @@ participate in the rule firing. So we mark them as Simplified to avoid re-simplifying them. -Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider+Note [Shadowing in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This part of the simplifier may return an expression that has shadowing.+(See Note [Shadowing in Core] in GHC.Core.hs.) Consider         f (...(\a -> e)...) (case y of (a,b) -> e') where f is strict in its second arg If we simplify the innermost one first we get (...(\a -> e)...)@@ -2431,6 +2453,8 @@ to get the effect that finding (error "foo") in a strict arg position will discard the entire application and replace it with (error "foo").  Getting all this at once is TOO HARD!++See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils.  Note [No eta-expansion in runRW#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -191,10 +191,11 @@   | StrictBind          -- (StrictBind x b K)[e] = let x = e in K[b]                         --       or, equivalently,  = K[ (\x.b) e ]       { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]-      , sc_bndr  :: InId       , sc_from  :: FromWhat+      , sc_bndr  :: InId       , sc_body  :: InExpr-      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_env   :: StaticEnv      -- Static env for both sc_bndr (stable unfolding thereof)+                                   -- and sc_body.  Also see Note [StaticEnv invariant]       , sc_cont  :: SimplCont }    | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]@@ -2279,7 +2280,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an /OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build-a new /InAlt/.  If you pass an OutId, we'll end up appling the+a new /InAlt/.  If you pass an OutId, we'll end up applying the substitution twice: disaster (#23012).  However this does mean that filling in the default alt might be

@@ -256,7 +256,7 @@         * Find the free variables of the abstracted pattern          * Pass these variables, less any that are in scope at-          the fn defn.  But see Note [Shadowing] below.+          the fn defn.  But see Note [Shadowing in SpecConstr] below.   NOTICE that we only abstract over variables that are not in scope,@@ -264,8 +264,8 @@ in f_spec's RHS.  -Note [Shadowing]-~~~~~~~~~~~~~~~~+Note [Shadowing in SpecConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In this pass we gather up usage information that may mention variables that are bound between the usage site and the definition site; or (more seriously) may be bound to something different at the definition site.@@ -1478,8 +1478,7 @@ scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _   e@(Lit {})   = return (nullUsage, e) scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e-                              (usg_t, t') <- scTickish env t-                              return (combineUsage usg usg_t, Tick t' e')+                              return (usg, Tick (scTickish env t) e') scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e                               return (usg, mkCast e' (scSubstCo env co))                               -- Important to use mkCast here@@ -1541,14 +1540,8 @@ -- | Substitute the free variables captured by a breakpoint. -- Variables are dropped if they have a non-variable substitution, like in -- 'GHC.Opt.Specialise.specTickish'.-scTickish :: ScEnv -> CoreTickish -> UniqSM (ScUsage, CoreTickish)-scTickish env = \case-  Breakpoint ext i fv -> do-    (usg, fv') <- unzip <$> mapM (\ v -> scExpr env (Var v)) fv-    pure (combineUsages usg, Breakpoint ext i [v | Var v <- fv'])-  t@ProfNote {} -> pure (nullUsage, t)-  t@HpcTick {} -> pure (nullUsage, t)-  t@SourceNote {} -> pure (nullUsage, t)+scTickish :: ScEnv -> CoreTickish -> CoreTickish+scTickish SCE {sc_subst = subst} = substTickish subst  {- Note [Do not specialise evals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2512,7 +2505,7 @@                 -- Quantify over variables that are not in scope                 -- at the call site                 -- See Note [Free type variables of the qvar types]-                -- See Note [Shadowing] at the top+                -- See Note [Shadowing in SpecConstr] at the top                (ktvs, ids)   = partition isTyVar qvars               qvars'        = scopedSort ktvs ++ map sanitise ids

@@ -68,6 +68,7 @@  import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) )+import GHC.Core.Subst (substTickish)  {- ************************************************************************@@ -1268,11 +1269,7 @@  -------------- specTickish :: SpecEnv -> CoreTickish -> CoreTickish-specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids)-  = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]]-  -- drop vars from the list if they have a non-variable substitution.-  -- should never happen, but it's harmless to drop them anyway.-specTickish _ other_tickish = other_tickish+specTickish (SE { se_subst = subst }) bp = substTickish subst bp  -------------- specCase :: SpecEnv

@@ -99,7 +99,14 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys  isDictTy :: Type -> Bool-isDictTy = isClassPred+-- True of dictionaries (Eq a) and+--         dictionary functions (forall a. Eq a => Eq [a])+-- See Note [Type determines value]+-- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs)+--     for why it's important to catch dictionary bindings+isDictTy ty = isClassPred pred+  where+    (_, pred) = splitInvisPiTys ty  typeDeterminesValue :: Type -> Bool -- See Note [Type determines value]

@@ -590,11 +590,13 @@      = exprFVs fv_expr (const True) emptyVarSet $! acc  ------------------+-- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish substTickish subst (Breakpoint ext n ids)    = Breakpoint ext n (mapMaybe do_one ids)  where     do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst+ substTickish _subst other = other  {- Note [Substitute lazily]

@@ -31,6 +31,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) import GHC.Core.Type     hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon@@ -1150,8 +1151,10 @@   -- TYPE and CONSTRAINT are not Apart   -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim   -- NB: at this point we know that the two TyCons do not match-  | Just {} <- sORTKind_maybe ty1-  , Just {} <- sORTKind_maybe ty2+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)   = maybeApart MARTypeVsConstraint     -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim     -- Note [Type and Constraint are not apart]

@@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) )+import Control.DeepSeq  infixr 3 `consBag` infixl 3 `snocBag`@@ -49,6 +50,12 @@   | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty   | ListBag (NonEmpty a)   deriving (Foldable, Functor, Traversable)++instance NFData a => NFData (Bag a) where+  rnf EmptyBag = ()+  rnf (UnitBag a) = rnf a+  rnf (TwoBags a b) = rnf a `seq` rnf b+  rnf (ListBag a) = rnf a  emptyBag :: Bag a emptyBag = EmptyBag

@@ -46,7 +46,7 @@  import GHC.Prelude -import GHC.Utils.Misc ( minWith, count )+import GHC.Utils.Misc ( sortWith, count ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust )@@ -219,47 +219,52 @@      [payload])         -- Rest of the path;                         --  [a,b,c] means c depends on b, b depends on a --- | Find a reasonably short cycle a->b->c->a, in a strongly--- connected component.  The input nodes are presumed to be--- a SCC, so you can start anywhere.+-- | Find a reasonably short cycle a->b->c->a, in a graph+-- The graph might not necessarily be strongly connected. findCycle :: forall payload key. Ord key           => [Node key payload]     -- The nodes.  The dependencies can                                     -- contain extra keys, which are ignored           -> Maybe [payload]        -- A cycle, starting with node                                     -- so each depends on the next findCycle graph-  = go Set.empty (new_work root_deps []) []+  = goRoots plausible_roots   where     env :: Map.Map key (Node key payload)     env = Map.fromList [ (node_key node, node) | node <- graph ] -    -- Find the node with fewest dependencies among the SCC modules-    -- This is just a heuristic to find some plausible root module-    root :: Node key payload-    root = fst (minWith snd [ (node, count (`Map.member` env)-                                           (node_dependencies node))-                            | node <- graph ])-    DigraphNode root_payload root_key root_deps = root+    goRoots [] = Nothing+    goRoots (root:xs) =+        case go Set.empty (new_work root_deps []) [] of+          Nothing -> goRoots xs+          Just res -> Just res+      where+        DigraphNode root_payload root_key root_deps = root+        -- 'go' implements Dijkstra's algorithm, more or less+        go :: Set.Set key   -- Visited+           -> [WorkItem key payload]        -- Work list, items length n+           -> [WorkItem key payload]        -- Work list, items length n+1+           -> Maybe [payload]               -- Returned cycle+           -- Invariant: in a call (go visited ps qs),+           --            visited = union (map tail (ps ++ qs)) +        go _       [] [] = Nothing  -- No cycles+        go visited [] qs = go visited qs []+        go visited (((DigraphNode payload key deps), path) : ps) qs+           | key == root_key           = Just (root_payload : reverse path)+           | key `Set.member` visited  = go visited ps qs+           | key `Map.notMember` env   = go visited ps qs+           | otherwise                 = go (Set.insert key visited)+                                            ps (new_qs ++ qs)+           where+             new_qs = new_work deps (payload : path) -    -- 'go' implements Dijkstra's algorithm, more or less-    go :: Set.Set key   -- Visited-       -> [WorkItem key payload]        -- Work list, items length n-       -> [WorkItem key payload]        -- Work list, items length n+1-       -> Maybe [payload]               -- Returned cycle-       -- Invariant: in a call (go visited ps qs),-       --            visited = union (map tail (ps ++ qs)) -    go _       [] [] = Nothing  -- No cycles-    go visited [] qs = go visited qs []-    go visited (((DigraphNode payload key deps), path) : ps) qs-       | key == root_key           = Just (root_payload : reverse path)-       | key `Set.member` visited  = go visited ps qs-       | key `Map.notMember` env   = go visited ps qs-       | otherwise                 = go (Set.insert key visited)-                                        ps (new_qs ++ qs)-       where-         new_qs = new_work deps (payload : path)+    -- Find the nodes with fewest dependencies among the SCC modules+    -- This is just a heuristic to find some plausible root module+    plausible_roots :: [Node key payload]+    plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node))+                                            | node <- graph ])+      new_work :: [key] -> [payload] -> [WorkItem key payload]     new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]

@@ -42,6 +42,8 @@   , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags   , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags   , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags+  , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags+  , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack dflags   , stgToCmmOmitYields    = gopt Opt_OmitYields            dflags   , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas  dflags   , stgToCmmPIC           = gopt Opt_PIC                   dflags

@@ -694,7 +694,8 @@         avx512er = False,         avx512f = False,         avx512pf = False,-        fma = False,+        -- Use FMA by default on AArch64+        fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64,         rtldInfo = panic "defaultDynFlags: no rtldInfo",         rtccInfo = panic "defaultDynFlags: no rtccInfo",         rtasmInfo = panic "defaultDynFlags: no rtasmInfo",

@@ -161,6 +161,7 @@    | Opt_D_no_debug_output    | Opt_D_dump_faststrings    | Opt_D_faststring_stats+   | Opt_D_ipe_stats    deriving (Eq, Show, Enum)  -- | Helper function to query whether a given `DumpFlag` is enabled or not.@@ -223,6 +224,8 @@     | Opt_DistinctConstructorTables    | Opt_InfoTableMap+   | Opt_InfoTableMapWithFallback+   | Opt_InfoTableMapWithStack     | Opt_WarnIsError                    -- -Werror; makes warnings fatal    | Opt_ShowWarnGroups                 -- Show the group a warning belongs to@@ -577,6 +580,8 @@      -- Flags that affect debugging information    , Opt_DistinctConstructorTables    , Opt_InfoTableMap+   , Opt_InfoTableMapWithStack+   , Opt_InfoTableMapWithFallback    ]  data WarningFlag =@@ -684,7 +689,7 @@    | Opt_WarnImplicitRhsQuantification               -- Since 9.8    | Opt_WarnIncompleteExportWarnings                -- Since 9.8    | Opt_WarnInconsistentFlags                       -- Since 9.8-   deriving (Eq, Ord, Show, Enum)+   deriving (Eq, Ord, Show, Enum, Bounded)  -- | Return the names of a WarningFlag --

@@ -1,37 +1,41 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs         #-}+{-# LANGUAGE TupleSections #-} -module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where+module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe, listToMaybe)+import Data.Semigroup ((<>)) import GHC.Cmm-import GHC.Cmm.CLabel (CLabel)-import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel)+import GHC.Cmm.Dataflow (O) import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)-import GHC.Cmm.Dataflow.Collections (mapToList)+import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label (Label) import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline)-import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv)-import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))+import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats)) import GHC.Driver.DynFlags (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep)-import GHC.Settings (Platform, platformTablesNextToCode)+import GHC.Settings (platformTablesNextToCode) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)+import GHC.StgToCmm.Utils import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.Tickish (GenTickish (SourceNote))-import GHC.Unit.Types (Module)-import GHC.Utils.Misc+import GHC.Unit.Types (Module, moduleName)+import GHC.Unit.Module (moduleNameString)+import qualified GHC.Utils.Logger as Logger+import GHC.Utils.Outputable (ppr)  {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]@@ -52,11 +56,17 @@  This leads to the question: How to figure out the source location of a return frame? -While the lookup algorithms when tables-next-to-code is on/off differ in details, they have in-common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest-(before) the usage of the return frame's label. (Which label and label type is used differs between-these two use cases.)+The algorithm for determining source locations for stack info tables is implemented in+`lookupEstimatedTicks` as two passes over every 'CmmGroupSRTs'. The first pass generates estimated+source locations for any labels potentially corresponding to stack info tables in the Cmm code. The+second pass walks over the Cmm decls and creates an entry in the IPE map for every info table,+looking up source locations for stack info tables in the map generated during the first pass. +The rest of this note will document exactly how the first pass generates the map from labels to+estimated source positions. The algorithms are different depending on whether tables-next-to-code+is on or off. Both algorithms have in common that we are looking for a `CmmNode.CmmTick`+(containing a `SourceNote`) that is near what we estimate to be the label of a return stack frame.+ With tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -107,16 +117,16 @@ Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit (`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. -So, given a stack represented info table (likely representing a return frame, but this isn't completely-sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:-  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the-    label of the return frame.-  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block-    backwards (from end to beginning).-  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as-    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are-    ignored.)+So, given a `CmmGraph`:+  - Look at the end of every block: If it is a `CmmNode.CmmCall` returning to some label, lookup+    the nearest `CmmNode.CmmTick` by traversing the middle part of the block backwards (from end to+    beginning).+  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and map the label we+    found to it's payload as an `IpeSourceLocation`. (There are other `Tickish` constructors like+    `ProfNote` or `HpcTick`, these are ignored.) +See `labelsToSourcesWithTNTC` for the implementation of this algorithm.+ Without tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -170,16 +180,27 @@ Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` (`label: block_c18M_info` is actually a `CLabel`). -The find the tick:-  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like-   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.-  - If such an assignment is found the search is over, because the payload (content of-    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always-    remembered in a `Maybe`.+Given a `CmmGraph`:+  - Check every `CmmBlock` from top (first) to bottom (last).+  - If a `CmmTick` holding a `SourceNote` is found, remember the source location in the tick.+  - If an assignment of the form `... = block_c18M_info;` (a `CmmStore` whose RHS is a+    `CmmLit (CmmLabel l)`) is found, map that label to the most recently visited source note's+    location.++See `labelsToSourcesSansTNTC` for the implementation of this algorithm. -} -generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos-generateCgIPEStub hsc_env this_mod denv s = do+generateCgIPEStub+  :: HscEnv+  -> Module+  -> InfoTableProvMap+  -> ( NonCaffySet+     , ModuleLFInfos+     , Map CmmInfoTable (Maybe IpeSourceLocation)+     , IPEStats+     )+  -> Stream IO CmmGroupSRTs CmmCgInfos+generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do   let dflags   = hsc_dflags hsc_env       platform = targetPlatform dflags       logger   = hsc_logger hsc_env@@ -187,82 +208,169 @@       cmm_cfg  = initCmmConfig dflags   cgState <- liftIO initC -  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.-  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing-  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s-   -- Yield Cmm for Info Table Provenance Entries (IPEs)-  let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}-      ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')+  let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}+      ((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv')    (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup   Stream.yield ipeCmmGroupSRTs -  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}-  where-    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)-    collect platform acc cmmGroupSRTs = do-      let labelsToInfoTables = collectInfoTables cmmGroupSRTs-          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables-      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)+  ipeStub <-+    case mIpeStub of+      Just (stats, stub) -> do+        -- Print ipe stats if requested+        liftIO $+          Logger.putDumpFileMaybe logger+            Opt_D_ipe_stats+            ("IPE Stats for module " ++ (moduleNameString $ moduleName this_mod))+            Logger.FormatText+            (ppr stats)+        return stub+      Nothing -> return mempty -    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)-    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)+  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} -    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]-    collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup+-- | Given:+--   * an initial mapping from info tables to possible source locations,+--   * initial 'IPEStats',+--   * a 'CmmGroupSRTs',+--+-- map every info table listed in the 'CmmProc's of the group to their possible+-- source locations and update 'IPEStats' for skipped stack info tables (in case+-- both -finfo-table-map and -fno-info-table-map-with-stack were given). See:+-- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+--+-- Note: While it would be cleaner if we could keep the recursion and+-- accumulation internal to this function, this cannot be done without+-- separately traversing stream of 'CmmGroupSRTs' in 'GHC.Driver.Main'. The+-- initial implementation of this logic did such a thing, and code generation+-- performance suffered considerably as a result (see #23103).+lookupEstimatedTicks+  :: HscEnv+  -> Map CmmInfoTable (Maybe IpeSourceLocation)+  -> IPEStats+  -> CmmGroupSRTs+  -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =+    -- Pass 2: Create an entry in the IPE map for every info table listed in+    -- this CmmGroupSRTs. If the info table is a stack info table and+    -- -finfo-table-map-with-stack is enabled, look up its estimated source+    -- location in the map generate during Pass 1. If the info table is a stack+    -- info table and -finfo-table-map-with-stack is not enabled, skip the table+    -- and note it as skipped in the IPE stats. If the info table is not a stack+    -- info table, insert into the IPE map with no source location information+    -- (for now; see `convertInfoProvMap` in GHC.StgToCmm.Utils to see how source+    -- locations for these tables get filled in)+    pure $ foldl' collectInfoTables (ipes, stats) cmm_group_srts+  where+    dflags = hsc_dflags hsc_env+    platform = targetPlatform dflags -    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]-    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)-    extractInfoTables _ = Nothing+    -- Pass 1: Map every label meeting the conditions described in Note+    -- [Stacktraces from Info Table Provenance Entries (IPE based stack+    -- unwinding)] to the estimated source location (also as described in the+    -- aformentioned note)+    --+    -- Note: It's important that this remains a thunk so we do not compute this+    -- map if -fno-info-table-with-stack is given+    labelsToSources :: Map CLabel IpeSourceLocation+    labelsToSources =+      if platformTablesNextToCode platform then+        foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts+      else+        foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts -    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation-    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do-      -- All return frame info tables are stack represented, though not all stack represented info-      -- tables have to be return frames.-      if (isStackRep . cit_rep) infoTable-        then do-          let findFun =-                if platformTablesNextToCode platform-                  then findCmmTickishWithTNTC infoTableLabel-                  else findCmmTickishSansTNTC (cit_lbl infoTable)-              blocks = concatMap toBlockList (graphs cmmGroup)-          firstJusts $ map findFun blocks-        else Nothing-    graphs :: CmmGroupSRTs -> [CmmGraph]-    graphs = foldl' go []+    collectInfoTables+      :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+      -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+      -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+    collectInfoTables (!acc, !stats) (CmmProc h _ _ _) =+        mapFoldlWithKey go (acc, stats) (info_tbls h)       where-        go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]-        go acc (CmmProc _ _ _ g) = g : acc-        go acc _ = acc--    findCmmTickishWithTNTC :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation-    findCmmTickishWithTNTC label block = do-      let (_, middleBlock, endBlock) = blockSplit block+        go :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+           -> Label+           -> CmmInfoTable+           -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+        go (!acc, !stats) lbl' tbl =+          let+            lbl =+              if platformTablesNextToCode platform then+                -- TNTC case, the mapped CLabel will be the result of+                -- mkAsmTempLabel on the info table label+                mkAsmTempLabel lbl'+              else+                -- Non-TNTC case, the mapped CLabel will be the CLabel of the+                -- info table itself+                cit_lbl tbl+          in+            if (isStackRep . cit_rep) tbl then+              if gopt Opt_InfoTableMapWithStack dflags then+                -- This is a stack info table and we DO want to put it in the+                -- info table map+                (Map.insert tbl (Map.lookup lbl labelsToSources) acc, stats)+              else+                -- This is a stack info table but we DO NOT want to put it in+                -- the info table map (-fno-info-table-map-with-stack was+                -- given), track it as skipped+                (acc, stats <> skippedIpeStats)+            else+              -- This is not a stack info table, so put it in the map with no+              -- source location (for now)+              (Map.insert tbl Nothing acc, stats)+    collectInfoTables (!acc, !stats) _ = (acc, stats) -      isCallWithReturnFrameLabel endBlock label-      lastTickInBlock middleBlock+-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesWithTNTC+  :: Map CLabel IpeSourceLocation+  -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+  -> Map CLabel IpeSourceLocation+labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) =+    foldl' go acc (toBlockList cmm_graph)+  where+    go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+    go acc block =+        case (,) <$> returnFrameLabel <*> lastTickInBlock of+          Just (clabel, src_loc) -> Map.insert clabel src_loc acc+          Nothing -> acc       where-        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()-        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()-        isCallWithReturnFrameLabel _ _ = Nothing+        (_, middleBlock, endBlock) = blockSplit block -        lastTickInBlock block =-          listToMaybe $-              mapMaybe maybeTick $ (reverse . blockToList) block+        returnFrameLabel :: Maybe CLabel+        returnFrameLabel =+          case endBlock of+            (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l+            _ -> Nothing -        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation-        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)-        maybeTick _ = Nothing+        lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) -    findCmmTickishSansTNTC :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation-    findCmmTickishSansTNTC cLabel block = do-      let (_, middleBlock, _) = blockSplit block-      find cLabel (blockToList middleBlock) Nothing+        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+        maybeTick _ s@(Just _) = s+        maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name)+        maybeTick _ _ = Nothing+labelsToSourcesWithTNTC acc _ = acc++-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesSansTNTC+  :: Map CLabel IpeSourceLocation+  -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+  -> Map CLabel IpeSourceLocation+labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) =+    foldl' go acc (toBlockList cmm_graph)+  where+    go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+    go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock)       where-        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation-        find label (b : blocks) lastTick = case b of-          (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick-          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)-          _ -> find label blocks lastTick-        find _ [] _ = Nothing+        (_, middleBlock, _) = blockSplit block++        collectLabels+          :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+          -> CmmNode O O+          -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+        collectLabels (!acc, lastTick) b =+          case (b, lastTick) of+            (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) ->+              (Map.insert l src_loc acc, Nothing)+            (CmmTick (SourceNote span name), _) ->+              (acc, Just (span, name))+            _ -> (acc, lastTick)+labelsToSourcesSansTNTC acc _ = acc

@@ -137,7 +137,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks)  import GHC.Runtime.Context import GHC.Runtime.Interpreter@@ -246,7 +246,6 @@ import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr-import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo import GHC.Types.Unique.Supply (uniqFromMask)@@ -281,11 +280,11 @@ import Data.IORef import System.FilePath as FilePath import System.Directory+import qualified Data.Map as M+import Data.Map (Map) import qualified Data.Set as S import Data.Set (Set)-import Data.Functor ((<&>)) import Control.DeepSeq (force)-import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.WholeCoreBindings import GHC.Types.TypeEnv@@ -296,8 +295,10 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) import GHC.Stg.InferTags.TagSig (seqTagSig)+import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM+import GHC.Cmm.Config (CmmConfig)   {- **********************************************************************@@ -2157,21 +2158,41 @@          cmm_config = initCmmConfig dflags -        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)+        pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos         pipeline_stream = do-          (non_cafs,  lf_infos) <-+          ((mod_srt_info, ipes, ipe_stats), lf_infos) <-             {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1-              <&> first (srtMapNonCAFs . moduleSRTMap)+            Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1+          let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)+          cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats)+          return cmmCgInfos -          return (non_cafs, lf_infos)+        pipeline_action+          :: Logger+          -> CmmConfig+          -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+          -> CmmGroup+          -> IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)+        pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do+          (mod_srt_info', cmm_srts) <- cmmPipeline logger cmm_config mod_srt_info cmm_group +          -- If -finfo-table-map is enabled, we precompute a map from info+          -- tables to source locations. See Note [Mapping Info Tables to Source+          -- Positions] in GHC.Stg.Debug.+          (ipes', stats') <-+            if (gopt Opt_InfoTableMap dflags) then+              lookupEstimatedTicks hsc_env ipes stats cmm_srts+            else+              return (ipes, stats)++          return ((mod_srt_info', ipes', stats'), cmm_srts)+         dump2 a = do           unless (null a) $             putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)           return a -    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream+    return $ Stream.mapM dump2 pipeline_stream  myCoreToStg :: Logger -> DynFlags -> [Var]             -> Bool

@@ -609,7 +609,7 @@               -- Now perform another toposort but just with these nodes and relevant hs-boot files.               -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.               mresolved_cycle = collapseSCC (topSortWithBoot nodes)-          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []+          in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []          (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)         trans_deps_map = allReachable mg (mkNodeKey . node_payload)@@ -640,12 +640,12 @@         get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing          -- Any cycles should be resolved now-        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]         -- Must be at least two nodes, as we were in a cycle-        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]-        collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes)         -- Cyclic-        collapseSCC _ = Nothing+        collapseSCC nodes = Left (flattenSCCs nodes)          toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile         toNodeWithBoot mn =@@ -772,6 +772,7 @@      let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }     setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env+    hsc_env <- getSession      -- Unload everything     liftIO $ unload interp hsc_env@@ -781,7 +782,6 @@      worker_limit <- liftIO $ mkWorkerLimit dflags -    setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env     (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do       hsc_env <- getSession       liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan@@ -1146,33 +1146,37 @@           -- which would retain all the result variables, preventing us from collecting them           -- after they are no longer used.           !build_deps = getDependencies direct_deps build_map-      let build_action =-            withCurrentUnit (moduleGraphNodeUnitId mod) $ do-            (hug, deps) <- wait_deps_hug hug_var build_deps+      let !build_action =             case mod of               InstantiationNode uid iu -> do-                executeInstantiationNode mod_idx n_mods hug uid iu-                return (Nothing, deps)-              ModuleNode _build_deps ms -> do+                withCurrentUnit (moduleGraphNodeUnitId mod) $ do+                  (hug, deps) <- wait_deps_hug hug_var build_deps+                  executeInstantiationNode mod_idx n_mods hug uid iu+                  return (Nothing, deps)+              ModuleNode _build_deps ms ->                 let !old_hmi = M.lookup (msKey ms) old_hpt                     rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes-                hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms-                -- Write the HMI to an external cache (if one exists)-                -- See Note [Caching HomeModInfo]-                liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi-                -- This global MVar is incrementally modified in order to avoid having to-                -- recreate the HPT before compiling each module which leads to a quadratic amount of work.-                liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)-                return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )+                in withCurrentUnit (moduleGraphNodeUnitId mod) $ do+                     (hug, deps) <- wait_deps_hug hug_var build_deps+                     hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms+                     -- Write the HMI to an external cache (if one exists)+                     -- See Note [Caching HomeModInfo]+                     liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+                     -- This global MVar is incrementally modified in order to avoid having to+                     -- recreate the HPT before compiling each module which leads to a quadratic amount of work.+                     liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)+                     return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )               LinkNode _nks uid -> do-                  executeLinkNode hug (mod_idx, n_mods) uid direct_deps-                  return (Nothing, deps)+                  withCurrentUnit (moduleGraphNodeUnitId mod) $ do+                    (hug, deps) <- wait_deps_hug hug_var build_deps+                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps+                    return (Nothing, deps)         res_var <- liftIO newEmptyMVar       let result_var = mkResultVar res_var       setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)-      return $ (MakeAction build_action res_var)+      return $! (MakeAction build_action res_var)       buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]@@ -2988,7 +2992,7 @@       run_pipeline :: RunMakeM a -> IO (Maybe a)       run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))+data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))  waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar

@@ -129,6 +129,7 @@  import Data.Time        ( getCurrentTime ) import GHC.Iface.Recomp+import GHC.Types.Unique.DSet  -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m@@ -497,8 +498,18 @@          -- next, check libraries. XXX this only checks Haskell libraries,         -- not extra_libraries or -l things from the command line.+        -- pkg_deps is just the direct dependencies so take the transitive closure here+        -- to decide if we need to relink or not.+        let pkg_hslibs acc uid+              | uid `elementOfUniqDSet` acc = acc+              | Just c <- lookupUnitId unit_state uid =+                  foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c)+              | otherwise = acc++            all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps+         let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)-                          | Just c <- map (lookupUnitId unit_state) pkg_deps,+                          | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps),                             lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]          pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs

@@ -990,6 +990,7 @@                | otherwise                   = "static"          platform = targetPlatform dflags+        arch = platformArch platform          align :: Int         align = case platformArch platform of@@ -1007,7 +1008,8 @@               ++ ["+avx512cd"| isAvx512cdEnabled dflags ]               ++ ["+avx512er"| isAvx512erEnabled dflags ]               ++ ["+avx512pf"| isAvx512pfEnabled dflags ]-              ++ ["+fma"     | isFmaEnabled dflags      ]+              -- For Arch64 +fma is not a option (it's unconditionally available).+              ++ ["+fma"     | isFmaEnabled dflags && (arch /= ArchAArch64) ]               ++ ["+bmi"     | isBmiEnabled dflags      ]               ++ ["+bmi2"    | isBmi2Enabled dflags     ] 

@@ -1566,6 +1566,8 @@         (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))   , make_ord_flag defGhcFlag "dshow-passes"         (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dipe-stats"+        (setDumpFlag Opt_D_ipe_stats)   , make_ord_flag defGhcFlag "dfaststring-stats"         (setDumpFlag Opt_D_faststring_stats)   , make_ord_flag defGhcFlag "dno-llvm-mangler"@@ -1804,10 +1806,6 @@         -- Caller-CC   , make_ord_flag defGhcFlag "fprof-callers"          (HasArg setCallerCcFilters)-  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"-      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))-  , make_ord_flag defGhcFlag "finfo-table-map"-      (NoArg (setGeneralFlag Opt_InfoTableMap))         ------ Compiler flags -----------------------------------------------    , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))@@ -2170,126 +2168,125 @@ wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)  wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]-wWarningFlagsDeps = mconcat [+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically-  warnSpec    Opt_WarnAlternativeLayoutRuleTransitional,-  warnSpec    Opt_WarnAmbiguousFields,-  depWarnSpec Opt_WarnAutoOrphans-              "it has no effect",-  warnSpec    Opt_WarnCPPUndef,-  warnSpec    Opt_WarnUnbangedStrictPatterns,-  warnSpec    Opt_WarnDeferredTypeErrors,-  warnSpec    Opt_WarnDeferredOutOfScopeVariables,-  warnSpec    Opt_WarnDeprecatedFlags,-  warnSpec    Opt_WarnDerivingDefaults,-  warnSpec    Opt_WarnDerivingTypeable,-  warnSpec    Opt_WarnDodgyExports,-  warnSpec    Opt_WarnDodgyForeignImports,-  warnSpec    Opt_WarnDodgyImports,-  warnSpec    Opt_WarnEmptyEnumerations,-  subWarnSpec "duplicate-constraints"-              Opt_WarnDuplicateConstraints-              "it is subsumed by -Wredundant-constraints",-  warnSpec    Opt_WarnRedundantConstraints,-  warnSpec    Opt_WarnDuplicateExports,-  depWarnSpec Opt_WarnHiShadows-              "it is not used, and was never implemented",-  warnSpec    Opt_WarnInaccessibleCode,-  warnSpec    Opt_WarnImplicitPrelude,-  depWarnSpec Opt_WarnImplicitKindVars-              "it is now an error",-  warnSpec    Opt_WarnIncompletePatterns,-  warnSpec    Opt_WarnIncompletePatternsRecUpd,-  warnSpec    Opt_WarnIncompleteUniPatterns,-  warnSpec    Opt_WarnInlineRuleShadowing,-  warnSpec    Opt_WarnIdentities,-  warnSpec    Opt_WarnMissingFields,-  warnSpec    Opt_WarnMissingImportList,-  warnSpec    Opt_WarnMissingExportList,-  subWarnSpec "missing-local-sigs"-              Opt_WarnMissingLocalSignatures-              "it is replaced by -Wmissing-local-signatures",-  warnSpec    Opt_WarnMissingLocalSignatures,-  warnSpec    Opt_WarnMissingMethods,-  depWarnSpec Opt_WarnMissingMonadFailInstances-              "fail is no longer a method of Monad",-  warnSpec    Opt_WarnSemigroup,-  warnSpec    Opt_WarnMissingSignatures,-  warnSpec    Opt_WarnMissingKindSignatures,-  warnSpec    Opt_WarnMissingPolyKindSignatures,-  subWarnSpec "missing-exported-sigs"-              Opt_WarnMissingExportedSignatures-              "it is replaced by -Wmissing-exported-signatures",-  warnSpec    Opt_WarnMissingExportedSignatures,-  warnSpec    Opt_WarnMonomorphism,-  warnSpec    Opt_WarnNameShadowing,-  warnSpec    Opt_WarnNonCanonicalMonadInstances,-  depWarnSpec Opt_WarnNonCanonicalMonadFailInstances-              "fail is no longer a method of Monad",-  warnSpec    Opt_WarnNonCanonicalMonoidInstances,-  warnSpec    Opt_WarnOrphans,-  warnSpec    Opt_WarnOverflowedLiterals,-  warnSpec    Opt_WarnOverlappingPatterns,-  warnSpec    Opt_WarnMissedSpecs,-  warnSpec    Opt_WarnAllMissedSpecs,-  warnSpec'   Opt_WarnSafe setWarnSafe,-  warnSpec    Opt_WarnTrustworthySafe,-  warnSpec    Opt_WarnInferredSafeImports,-  warnSpec    Opt_WarnMissingSafeHaskellMode,-  warnSpec    Opt_WarnTabs,-  warnSpec    Opt_WarnTypeDefaults,-  warnSpec    Opt_WarnTypedHoles,-  warnSpec    Opt_WarnPartialTypeSignatures,-  warnSpec    Opt_WarnUnrecognisedPragmas,-  warnSpec    Opt_WarnMisplacedPragmas,-  warnSpec'   Opt_WarnUnsafe setWarnUnsafe,-  warnSpec    Opt_WarnUnsupportedCallingConventions,-  warnSpec    Opt_WarnUnsupportedLlvmVersion,-  warnSpec    Opt_WarnMissedExtraSharedLib,-  warnSpec    Opt_WarnUntickedPromotedConstructors,-  warnSpec    Opt_WarnUnusedDoBind,-  warnSpec    Opt_WarnUnusedForalls,-  warnSpec    Opt_WarnUnusedImports,-  warnSpec    Opt_WarnUnusedLocalBinds,-  warnSpec    Opt_WarnUnusedMatches,-  warnSpec    Opt_WarnUnusedPatternBinds,-  warnSpec    Opt_WarnUnusedTopBinds,-  warnSpec    Opt_WarnUnusedTypePatterns,-  warnSpec    Opt_WarnUnusedRecordWildcards,-  warnSpec    Opt_WarnRedundantBangPatterns,-  warnSpec    Opt_WarnRedundantRecordWildcards,-  warnSpec    Opt_WarnRedundantStrictnessFlags,-  warnSpec    Opt_WarnWrongDoBind,-  warnSpec    Opt_WarnMissingPatternSynonymSignatures,-  warnSpec    Opt_WarnMissingDerivingStrategies,-  warnSpec    Opt_WarnSimplifiableClassConstraints,-  warnSpec    Opt_WarnMissingHomeModules,-  warnSpec    Opt_WarnUnrecognisedWarningFlags,-  warnSpec    Opt_WarnStarBinder,-  warnSpec    Opt_WarnStarIsType,-  depWarnSpec Opt_WarnSpaceAfterBang-              "bang patterns can no longer be written with a space",-  warnSpec    Opt_WarnPartialFields,-  warnSpec    Opt_WarnPrepositiveQualifiedModule,-  warnSpec    Opt_WarnUnusedPackages,-  warnSpec    Opt_WarnCompatUnqualifiedImports,-  warnSpec    Opt_WarnInvalidHaddock,-  warnSpec    Opt_WarnOperatorWhitespaceExtConflict,-  warnSpec    Opt_WarnOperatorWhitespace,-  warnSpec    Opt_WarnImplicitLift,-  warnSpec    Opt_WarnMissingExportedPatternSynonymSignatures,-  warnSpec    Opt_WarnForallIdentifier,-  warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,-  warnSpec    Opt_WarnGADTMonoLocalBinds,-  warnSpec    Opt_WarnTypeEqualityOutOfScope,-  warnSpec    Opt_WarnTypeEqualityRequiresOperators,-  warnSpec    Opt_WarnTermVariableCapture,-  warnSpec    Opt_WarnMissingRoleAnnotations,-  warnSpec    Opt_WarnImplicitRhsQuantification,-  warnSpec    Opt_WarnIncompleteExportWarnings- ]+  Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x+  Opt_WarnAmbiguousFields -> warnSpec x+  Opt_WarnAutoOrphans+    -> depWarnSpec x  "it has no effect"+  Opt_WarnCPPUndef -> warnSpec x+  Opt_WarnUnbangedStrictPatterns -> warnSpec x+  Opt_WarnDeferredTypeErrors -> warnSpec x+  Opt_WarnDeferredOutOfScopeVariables -> warnSpec x+  Opt_WarnDeprecatedFlags -> warnSpec x+  Opt_WarnDerivingDefaults -> warnSpec x+  Opt_WarnDerivingTypeable -> warnSpec x+  Opt_WarnDodgyExports -> warnSpec x+  Opt_WarnDodgyForeignImports -> warnSpec x+  Opt_WarnDodgyImports -> warnSpec x+  Opt_WarnEmptyEnumerations -> warnSpec x+  Opt_WarnDuplicateConstraints+    -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"+  Opt_WarnRedundantConstraints -> warnSpec x+  Opt_WarnDuplicateExports -> warnSpec x+  Opt_WarnHiShadows+    -> depWarnSpec x "it is not used, and was never implemented"+  Opt_WarnInaccessibleCode -> warnSpec x+  Opt_WarnImplicitPrelude -> warnSpec x+  Opt_WarnImplicitKindVars+    -> depWarnSpec x "it is now an error"+  Opt_WarnIncompletePatterns -> warnSpec x+  Opt_WarnIncompletePatternsRecUpd -> warnSpec x+  Opt_WarnIncompleteUniPatterns -> warnSpec x+  Opt_WarnInconsistentFlags -> warnSpec x+  Opt_WarnInlineRuleShadowing -> warnSpec x+  Opt_WarnIdentities -> warnSpec x+  Opt_WarnLoopySuperclassSolve -> warnSpec x+  Opt_WarnMissingFields -> warnSpec x+  Opt_WarnMissingImportList -> warnSpec x+  Opt_WarnMissingExportList -> warnSpec x+  Opt_WarnMissingLocalSignatures+    -> subWarnSpec "missing-local-sigs" x+                 "it is replaced by -Wmissing-local-signatures"+       ++ warnSpec x+  Opt_WarnMissingMethods -> warnSpec x+  Opt_WarnMissingMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnSemigroup -> warnSpec x+  Opt_WarnMissingSignatures -> warnSpec x+  Opt_WarnMissingKindSignatures -> warnSpec x+  Opt_WarnMissingPolyKindSignatures -> warnSpec x+  Opt_WarnMissingExportedSignatures+    -> subWarnSpec "missing-exported-sigs" x+                   "it is replaced by -Wmissing-exported-signatures"+       ++ warnSpec x+  Opt_WarnMonomorphism -> warnSpec x+  Opt_WarnNameShadowing -> warnSpec x+  Opt_WarnNonCanonicalMonadInstances -> warnSpec x+  Opt_WarnNonCanonicalMonadFailInstances -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnNonCanonicalMonoidInstances -> warnSpec x+  Opt_WarnOrphans -> warnSpec x+  Opt_WarnOverflowedLiterals -> warnSpec x+  Opt_WarnOverlappingPatterns -> warnSpec x+  Opt_WarnMissedSpecs -> warnSpec x+  Opt_WarnAllMissedSpecs -> warnSpec x+  Opt_WarnSafe -> warnSpec' x setWarnSafe+  Opt_WarnTrustworthySafe -> warnSpec x+  Opt_WarnInferredSafeImports -> warnSpec x+  Opt_WarnMissingSafeHaskellMode -> warnSpec x+  Opt_WarnTabs -> warnSpec x+  Opt_WarnTypeDefaults -> warnSpec x+  Opt_WarnTypedHoles -> warnSpec x+  Opt_WarnPartialTypeSignatures -> warnSpec x+  Opt_WarnUnrecognisedPragmas -> warnSpec x+  Opt_WarnMisplacedPragmas -> warnSpec x+  Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe+  Opt_WarnUnsupportedCallingConventions -> warnSpec x+  Opt_WarnUnsupportedLlvmVersion -> warnSpec x+  Opt_WarnMissedExtraSharedLib -> warnSpec x+  Opt_WarnUntickedPromotedConstructors -> warnSpec x+  Opt_WarnUnusedDoBind -> warnSpec x+  Opt_WarnUnusedForalls -> warnSpec x+  Opt_WarnUnusedImports -> warnSpec x+  Opt_WarnUnusedLocalBinds -> warnSpec x+  Opt_WarnUnusedMatches -> warnSpec x+  Opt_WarnUnusedPatternBinds -> warnSpec x+  Opt_WarnUnusedTopBinds -> warnSpec x+  Opt_WarnUnusedTypePatterns -> warnSpec x+  Opt_WarnUnusedRecordWildcards -> warnSpec x+  Opt_WarnRedundantBangPatterns -> warnSpec x+  Opt_WarnRedundantRecordWildcards -> warnSpec x+  Opt_WarnRedundantStrictnessFlags -> warnSpec x+  Opt_WarnWrongDoBind -> warnSpec x+  Opt_WarnMissingPatternSynonymSignatures -> warnSpec x+  Opt_WarnMissingDerivingStrategies -> warnSpec x+  Opt_WarnSimplifiableClassConstraints -> warnSpec x+  Opt_WarnMissingHomeModules -> warnSpec x+  Opt_WarnUnrecognisedWarningFlags -> warnSpec x+  Opt_WarnStarBinder -> warnSpec x+  Opt_WarnStarIsType -> warnSpec x+  Opt_WarnSpaceAfterBang+    -> depWarnSpec x "bang patterns can no longer be written with a space"+  Opt_WarnPartialFields -> warnSpec x+  Opt_WarnPrepositiveQualifiedModule -> warnSpec x+  Opt_WarnUnusedPackages -> warnSpec x+  Opt_WarnCompatUnqualifiedImports -> warnSpec x+  Opt_WarnInvalidHaddock -> warnSpec x+  Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x+  Opt_WarnOperatorWhitespace -> warnSpec x+  Opt_WarnImplicitLift -> warnSpec x+  Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x+  Opt_WarnForallIdentifier -> warnSpec x+  Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x+  Opt_WarnGADTMonoLocalBinds -> warnSpec x+  Opt_WarnTypeEqualityOutOfScope -> warnSpec x+  Opt_WarnTypeEqualityRequiresOperators -> warnSpec x+  Opt_WarnTermVariableCapture -> warnSpec x+  Opt_WarnMissingRoleAnnotations -> warnSpec x+  Opt_WarnImplicitRhsQuantification -> warnSpec x+  Opt_WarnIncompleteExportWarnings -> warnSpec x  warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups@@ -2485,7 +2482,11 @@   flagSpec "show-error-context"               Opt_ShowErrorContext,   flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,   flagSpec "split-sections"                   Opt_SplitSections,-  flagSpec "break-points"                     Opt_InsertBreakpoints+  flagSpec "break-points"                     Opt_InsertBreakpoints,+  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,+  flagSpec "info-table-map"                   Opt_InfoTableMap,+  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,+  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback   ]   ++ fHoleFlags @@ -2779,6 +2780,8 @@                 ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)                 ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface)                 ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)                 ] ++ validHoleFitsImpliedGFlags  -- General flags that are switched on/off when other general flags are switched

@@ -849,7 +849,16 @@   = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]    | otherwise = case decompose fun2 args2 of-        Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2)+        Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+                   --                                    , text "orig_lhs:" <+> ppr orig_lhs+                   --                                    , text "rhs_fvs:" <+> ppr rhs_fvs+                   --                                    , text "orig_lhs:" <+> ppr orig_lhs+                   --                                    , text "lhs1:" <+> ppr lhs1+                   --                                    , text "lhs2:" <+> ppr lhs2+                   --                                    , text "fun2:" <+> ppr fun2+                   --                                    , text "args2:" <+> ppr args2+                   --                                    ]) $+                   Left (DsRuleLhsTooComplicated orig_lhs lhs2)         Just (fn_id, args)           | not (null unbound) ->             -- Check for things unbound on LHS@@ -921,7 +930,9 @@     split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)    split_lets (Let (NonRec d r) body)-     | isDictId d+     | isDictId d  -- Catches dictionaries, yes, but also catches dictionary+                   -- /functions/ arising from solving a+                   -- quantified contraint (#24370)      = ((d,r):bs, body')      where (bs, body') = split_lets body 

@@ -554,7 +554,7 @@      ,   ppUnless res_hty_is_unit $          if libffi                   then char '*' <> parens (ffi_cResType <> char '*') <>-                       text "resp = cret;"+                       text "resp = " <> parens ffi_cResType <> text "cret;"                   else text "return cret;"      , rbrace      ]

@@ -279,9 +279,10 @@     mod_hidden pkg =         text "it is a hidden module in the package" <+> quotes (ppr pkg) -    unusable (pkg, reason)-      = text "It is a member of the package"-      <+> quotes (ppr pkg)+    unusable (UnusableUnit unit reason reexport)+      = text "It is " <> (if reexport then text "reexported from the package"+                                      else text "a member of the package")+      <+> quotes (ppr unit)       $$ pprReason (text "which is") reason  

@@ -25,7 +25,7 @@ import GHC.Types.Name (Name) import GHC.Types.TyThing (TyThing) import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit)-import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnitReason, UnitInfo)+import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo) import GHC.Exception.Type (SomeException) import GHC.Unit.Types ( IsBootInterface ) import Language.Haskell.Syntax.Module.Name ( ModuleName )@@ -80,7 +80,7 @@   | CouldntFindInFiles [FilePath]   | GenericMissing       [(Unit, Maybe UnitInfo)] [Unit]-      [(Unit, UnusableUnitReason)] [FilePath]+      [UnusableUnit] [FilePath]   | MultiplePackages [(Module, ModuleOrigin)]   deriving Generic 

@@ -825,7 +825,7 @@                       Just def -> forkM (mk_at_doc tc)                 $                                   extendIfaceTyVarEnv (tyConTyVars tc) $                                   do { tc_def <- tcIfaceType def-                                     ; return (Just (tc_def, NoATVI)) }+                                     ; return (Just (tc_def, NoVI)) }                   -- Must be done lazily in case the RHS of the defaults mention                   -- the type constructor being defined here                   -- e.g.   type AT a; type AT b = AT [b]   #8002

@@ -11,6 +11,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways+import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule))  import GHC.Driver.Config.Linker import GHC.Driver.Session@@ -150,6 +151,9 @@             --   dynamic binding nonsense when referring to symbols from             --   within the library. The NCG assumes that this option is             --   specified (on i386, at least).+            --   In XCode 15, -single_module is the default and passing the+            --   flag is now obsolete and raises a warning (#24168). We encode+            --   this information into the toolchain field ...SupportsSingleModule.             -- -install_name             --   Mac OS/X stores the path where a dynamic library is (to             --   be) installed in the library itself.  It's called the@@ -175,8 +179,11 @@                     ]                  ++ map Option o_files                  ++ [ Option "-undefined",-                      Option "dynamic_lookup",-                      Option "-single_module" ]+                      Option "dynamic_lookup"+                    ]+                 ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags)+                        then [ Option "-single_module" ]+                        else [ ])                  ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]                      then [ ]                      else [ Option "-Wl,-read_only_relocs,suppress" ])

@@ -27,7 +27,7 @@     ppLit,     ppTypeLit,     ppName,-    ppPlainName+    ppPlainName,      ) where @@ -40,7 +40,6 @@ import Data.List ( intersperse ) import GHC.Utils.Outputable -import GHC.Cmm.MachOp ( FMASign(..), pprFMASign ) import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique@@ -289,7 +288,6 @@         AtomicRMW  aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering         CmpXChg    addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord         Phi        tp predecessors  -> ppPhi opts tp predecessors-        FMAOp      op x y z         -> pprFMAOp opts op x y z         Asm        asm c ty v se sk -> ppAsm opts asm c ty v se sk         MExpr      meta expr        -> ppMetaAnnotExpr opts meta expr {-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-}@@ -375,13 +373,6 @@         <+> ppName opts left <> comma <+> ppName opts right {-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-} {-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable--pprFMAOp :: IsLine doc => LlvmCgConfig -> FMASign -> LlvmVar -> LlvmVar -> LlvmVar -> doc-pprFMAOp opts signs x y z =-  pprFMASign signs <+> ppLlvmType (getVarType x)-        <+> ppName opts x <> comma-        <+> ppName opts y <> comma-        <+> ppName opts z  ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc ppAssignment opts var expr = ppName opts var <+> equals <+> expr

@@ -10,7 +10,6 @@ import GHC.Llvm.Types  import GHC.Types.Unique-import GHC.Cmm.MachOp ( FMASign(..) )  -- | Block labels type LlvmBlockId = Unique@@ -338,8 +337,6 @@                      expression is executed.   -}   | Asm LMString LMString LlvmType [LlvmVar] Bool Bool--  | FMAOp FMASign LlvmVar LlvmVar LlvmVar    {- |     A LLVM expression with metadata attached to it.

@@ -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.8.1-src/ghc-9.8.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -109,7 +109,7 @@   , (0,alex_action_1)   ] -{-# LINE 86 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 86 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.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.8.1-src/ghc-9.8.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -789,7 +789,7 @@   , (0,alex_action_101)   ] -{-# LINE 794 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 794 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs   = OpWsPrefix         -- a !b@@ -1483,7 +1483,7 @@ nested_doc_comment :: Action nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker   where-    worker input docType _checkNextLine = nested_comment_logic endComment "" input span+    worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span))       where         endComment input lcomment           = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span

@@ -4,7 +4,6 @@  import GHC.Prelude --- TODO-#define MACHREGS_NO_REGS 1--- #define MACHREGS_wasm32 1+#define MACHREGS_NO_REGS 0+#define MACHREGS_wasm32 1 #include "CodeGen.Platform.h"

@@ -40,5 +40,5 @@ rnHsDocIdentifiers gre_env ns =   [ L l $ greName gre   | L l rdr_name <- ns-  , gre <- lookupGRE gre_env (LookupOccName (rdrNameOcc rdr_name) AllRelevantGREs)+  , gre <- lookupGRE gre_env (LookupRdrName rdr_name AllRelevantGREs)   ]

@@ -695,13 +695,14 @@   | otherwise = do   gre_env <- getGlobalRdrEnv   let original_gres = lookupGRE gre_env (LookupChildren (rdrNameOcc rdr_name) how_lkup)-  -- The remaining GREs are things that we *could* export here, note that-  -- this includes things which have `NoParent`. Those are sorted in-  -- `checkPatSynParent`.+      picked_gres = pick_gres original_gres+  -- The remaining GREs are things that we *could* export here.+  -- Note that this includes things which have `NoParent`;+  -- those are sorted in `checkPatSynParent`.   traceRn "parent" (ppr parent)   traceRn "lookupExportChild original_gres:" (ppr original_gres)-  traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent)-  case picked_gres original_gres of+  traceRn "lookupExportChild picked_gres:" (ppr picked_gres $$ ppr must_have_parent)+  case picked_gres of     NoOccurrence ->       noMatchingParentErr original_gres     UniqueOccurrence g ->@@ -748,34 +749,36 @@           addNameClashErrRn rdr_name gres           return (FoundChild (NE.head gres)) -        picked_gres :: [GlobalRdrElt] -> DisambigInfo+        pick_gres :: [GlobalRdrElt] -> DisambigInfo         -- For Unqual, find GREs that are in scope qualified or unqualified         -- For Qual,   find GREs that are in scope with that qualification-        picked_gres gres+        pick_gres gres           | isUnqual rdr_name           = mconcat (map right_parent gres)           | otherwise           = mconcat (map right_parent (pickGREs rdr_name gres))          right_parent :: GlobalRdrElt -> DisambigInfo-        right_parent p-          = case greParent p of+        right_parent gre+          = case greParent gre of               ParentIs cur_parent-                 | parent == cur_parent -> DisambiguatedOccurrence p+                 | parent == cur_parent -> DisambiguatedOccurrence gre                  | otherwise            -> NoOccurrence-              NoParent                  -> UniqueOccurrence p+              NoParent                  -> UniqueOccurrence gre {-# INLINEABLE lookupSubBndrOcc_helper #-} --- This domain specific datatype is used to record why we decided it was+-- | This domain specific datatype is used to record why we decided it was -- possible that a GRE could be exported with a parent. data DisambigInfo        = NoOccurrence-          -- The GRE could never be exported. It has the wrong parent.+          -- ^ The GRE could not be found, or it has the wrong parent.        | UniqueOccurrence GlobalRdrElt-          -- The GRE has no parent. It could be a pattern synonym.+          -- ^ The GRE has no parent. It could be a pattern synonym.        | DisambiguatedOccurrence GlobalRdrElt-          -- The parent of the GRE is the correct parent+          -- ^ The parent of the GRE is the correct parent.        | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt)+          -- ^ The GRE is ambiguous.+          --           -- For example, two normal identifiers with the same name are in           -- scope. They will both be resolved to "UniqueOccurrence" and the           -- monoid will combine them to this failing case.@@ -787,7 +790,7 @@   ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres  instance Semi.Semigroup DisambigInfo where-  -- This is the key line: We prefer disambiguated occurrences to other+  -- These are the key lines: we prefer disambiguated occurrences to other   -- names.   _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'   DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'

@@ -71,9 +71,9 @@  import Control.Monad import Control.Arrow ( first )-import Data.Foldable ( toList )+import Data.Foldable ( toList, for_ ) import Data.List ( mapAccumL )-import Data.List.NonEmpty ( NonEmpty(..), head )+import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields)@@ -725,9 +725,10 @@                && not (cls_tkv `elemNameSet` pat_fvs)                     -- ...but not bound on the LHS.              bad_tvs = filter improperly_scoped inst_head_tvs-       ; unless (null bad_tvs) $ addErr $+       ; for_ (nonEmpty bad_tvs) $ \ ne_bad_tvs ->+           addErr $            TcRnIllegalInstance $ IllegalFamilyInstance $-             FamInstRHSOutOfScopeTyVars Nothing bad_tvs+             FamInstRHSOutOfScopeTyVars Nothing ne_bad_tvs         ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs              -- See Note [Type family equations and occurrences]

@@ -1068,14 +1068,18 @@ these two exports, respectively, during construction of the imp_occ_env, we begin by associating the following two elements with the key T: -  T -> ImpOccItem { imp_item = T, imp_bundled = [C,T]     , imp_is_parent = False }-  T -> ImpOccItem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True  }+  T -> ImpOccItem { imp_item = gre1, imp_bundled = [C,T]     , imp_is_parent = False }+  T -> ImpOccItem { imp_item = gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True  } -We combine these (in function 'combine' in 'mkImportOccEnv') by simply discarding-the first item, to get:+where `gre1`, `gre2` are two GlobalRdrElts with greName T.+We combine these (in function 'combine' in 'mkImportOccEnv') by discarding the+non-parent item, thusly: -  T -> IE_ITem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True }+  T -> IE_ITem { imp_item = gre1 `plusGRE` gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } +Note the `plusGRE`: this ensures we don't drop parent information;+see Note [Preserve parent information when combining import OccEnvs].+ So the overall imp_occ_env is:    C  -> ImpOccItem { imp_item = C,  imp_bundled = [T       ], imp_is_parent = True  }@@ -1133,6 +1137,31 @@ which looks up 'S' and then finds the unique 'foo' amongst its children.  See T16745 for a test of this.++Note [Preserve parent information when combining import OccEnvs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When discarding one ImpOccItem in favour of another, as described in+Note [Dealing with imports], we must make sure to combine the GREs so that+we don't lose information.++Consider for example #24084:++  module M1 where { class C a where { type T a } }+  module M2 ( module M1 ) where { import M1 }+  module M3 where { import M2 ( C, T ); instance C () where T () = () }++When processing the import list of `M3`, we will have two `Avail`s attached+to `T`, namely `C(C, T)` and `T(T)`. We combine them in the `combine` function+of `mkImportOccEnv`; as described in Note [Dealing with imports] we discard+`C(C, T)` in favour of `T(T)`. However, in doing so, we **must not**+discard the information want that `C` is the parent of `T`. Indeed,+losing track of this information can cause errors when importing,+as we could get an error of the form++  ‘T’ is not a (visible) associated type of class ‘C’++This explains why we use `plusGRE` when combining the two ImpOccItems, even+though we are discarding one in favour of the other. -}  -- | All the 'GlobalRdrElt's associated with an 'AvailInfo'.@@ -1439,6 +1468,14 @@         -- ^ Is the import item a parent? See Note [Dealing with imports].       } +instance Outputable ImpOccItem where+  ppr (ImpOccItem { imp_item = item, imp_bundled = bundled, imp_is_parent = is_par })+    = braces $ hsep+       [ text "ImpOccItem"+       , if is_par then text "[is_par]" else empty+       , ppr (greName item) <+> ppr (greParent item)+       , braces $ text "bundled:" <+> ppr (map greName bundled) ]+ -- | Make an 'OccEnv' of all the imports. -- -- Complicated by the fact that associated data types and pattern synonyms@@ -1465,9 +1502,9 @@      -- See Note [Dealing with imports]     -- 'combine' may be called for associated data types which appear-    -- twice in the all_avails. In the example, we combine-    --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)-    -- NB: the AvailTC can have fields as well as data constructors (#12127)+    -- twice in the all_avails. In the example, we have two Avails for T,+    -- namely T(T,T1,T2,T3) and C(C,T), and we combine them by dropping the+    -- latter, in which T is not the parent.     combine :: ImpOccItem -> ImpOccItem -> ImpOccItem     combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 })             item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 })@@ -1475,11 +1512,13 @@       , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo.       , let name1 = greName gre1             name2 = greName gre2+            gre = gre1 `plusGRE` gre2+              -- See Note [Preserve parent information when combining import OccEnvs]       = assertPpr (name1 == name2)                   (ppr name1 <+> ppr name2) $         if is_parent1-        then item1-        else item2+        then item1 { imp_item = gre }+        else item2 { imp_item = gre }       -- Discard C(C,T) in favour of T(T, T1, T2, T3).      -- 'combine' may also be called for pattern synonyms which appear both

@@ -172,7 +172,7 @@         where           (loc,occ) = get_loc_occ n           mb_local  = lookupLocalRdrOcc local_env occ-          gres      = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantBoth))+          gres      = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantNormal))                 -- Make an Unqualified RdrName and look that up, so that                 -- we don't find any GREs that are in scope qualified-only 

@@ -175,7 +175,7 @@   | RTSRep              -- The RTS needs to declare info tables with specific         Int             -- type tags, so this form lets us override the default         SMRep           -- tag for an SMRep.-  deriving Eq+  deriving (Eq, Ord)  -- | True \<=> This is a static closure.  Affects how we garbage-collect it. -- Static closure have an extra static link field at the end.@@ -193,7 +193,7 @@   | ThunkSelector SelectorOffset   | BlackHole   | IndStatic-  deriving Eq+  deriving (Eq, Ord)  type ConstrDescription = ByteString -- result of dataConIdentity type FunArity          = Int@@ -223,7 +223,7 @@   | ArgUnknown          -- For imported binds.                         -- Invariant: Never Unknown for binds of the module                         -- we are compiling.-  deriving (Eq)+  deriving (Eq, Ord)  instance Outputable ArgDescr where   ppr (ArgSpec n) = text "ArgSpec" <+> ppr n

@@ -89,6 +89,7 @@   { toolSettings_ldSupportsCompactUnwind :: Bool   , toolSettings_ldSupportsFilelist      :: Bool   , toolSettings_ldSupportsResponseFiles :: Bool+  , toolSettings_ldSupportsSingleModule  :: Bool   , toolSettings_ldIsGnuLd               :: Bool   , toolSettings_ccSupportsNoPie         :: Bool   , toolSettings_useInplaceMinGW         :: Bool

@@ -105,6 +105,7 @@   ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"   ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"   ldSupportsResponseFiles <- getBooleanSetting "ld supports response files"+  ldSupportsSingleModule  <- getBooleanSetting "ld supports single module"   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"   arSupportsDashL         <- getBooleanSetting "ar supports -L" @@ -174,6 +175,7 @@       { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind       , toolSettings_ldSupportsFilelist      = ldSupportsFilelist       , toolSettings_ldSupportsResponseFiles = ldSupportsResponseFiles+      , toolSettings_ldSupportsSingleModule  = ldSupportsSingleModule       , toolSettings_ldIsGnuLd               = ldIsGnuLd       , toolSettings_ccSupportsNoPie         = gccSupportsNoPie       , toolSettings_useInplaceMinGW         = useInplaceMinGW

@@ -165,8 +165,8 @@         -- ^ This substitution is applied to the code as we traverse it.         --   Entries have one of two reasons:         ---        --   * The input might have shadowing (see Note [Shadowing]), so we have-        --     to rename some binders as we traverse the tree.+        --   * The input might have shadowing (see Note [Shadowing in Core]),+        --     so we have to rename some binders as we traverse the tree.         --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,         --     we note this here as x ↦ y.     , ce_bndrMap     :: IdEnv OutId

@@ -210,7 +210,7 @@ 1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from. 3. Stack represented info tables (return frames) to an approximated source location-   of the call that pushed a contiunation on the stacks.+   of the call that pushed a continuation on the stacks.  During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded@@ -253,7 +253,7 @@  In the old times, each usage of a data constructor used the same info table. This made it impossible to distinguish which actual usage of a data constructor was-contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you+contributing primarily to the allocation in a program. Using the `-fdistinct-constructor-tables` flag you can cause code generation to generate a distinct info table for each usage of a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor was responsible for each allocation.

@@ -553,7 +553,13 @@                 -- Extend reader monad with information that                 -- self-recursive tail calls can be optimized into local                 -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.-                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+                ; let !self_loop_info = MkSelfLoopInfo+                        { sli_id = bndr+                        , sli_arity = arity+                        , sli_header_block = loop_header_id+                        , sli_registers = arg_regs+                        }+                ; withSelfLoop self_loop_info $ do                 {                 -- Main payload                 ; entryHeapCheck cl_info node' arity arg_regs $ do@@ -702,11 +708,19 @@    when eager_blackholing $ do     whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node-    emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform)+    emitAtomicStore platform MemOrderRelease+        (cmmOffsetW platform node (fixedHdrSizeW profile))+        (currentTSOExpr platform)     -- See Note [Heap memory barriers] in SMP.h.-    let w = wordWidth platform-    emitPrimCall [] (MO_AtomicWrite w MemOrderRelease)-        [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)]+    emitAtomicStore platform MemOrderRelease+        node+        (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform))++emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()+emitAtomicStore platform mord addr val =+    emitPrimCall [] (MO_AtomicWrite w mord) [addr, val]+  where+    w = typeWidth $ cmmExprType platform val  setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()         -- Nota Bene: this function does not change Node (even if it's a CAF),

@@ -177,16 +177,18 @@                                      (globalRegSpillType platform reg)                                      NaturallyAligned -        CmmRegOff (CmmGlobal reg_use) offset ->+        CmmRegOff greg@(CmmGlobal reg) offset ->             -- RegOf leaves are just a shorthand form. If the reg maps             -- to a real reg, we keep the shorthand, otherwise, we just             -- expand it and defer to the above code.-            let reg = globalRegUseGlobalReg reg_use in-            case reg `elem` activeStgRegs platform of+            -- NB: to ensure type correctness we need to ensure the Add+            --     as well as the Int need to be of the same size as the+            --     register.+            case globalRegUseGlobalReg reg `elem` activeStgRegs platform of                 True  -> expr-                False -> CmmMachOp (MO_Add (wordWidth platform)) [-                                    fixExpr (CmmReg (CmmGlobal reg_use)),+                False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [+                                    fixExpr (CmmReg greg),                                     CmmLit (CmmInt (fromIntegral offset)-                                                   (wordWidth platform))]+                                                   (cmmRegWidth greg))]          other_expr -> other_expr

@@ -95,7 +95,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Utils.Misc import GHC.Data.Maybe (isNothing)  import Data.Coerce (coerce)@@ -539,12 +538,12 @@  getCallMethod :: StgToCmmConfig               -> Name           -- Function being applied-              -> Id             -- Function Id used to chech if it can refer to+              -> Id             -- Function Id used to check if it can refer to                                 -- CAF's and whether the function is tail-calling                                 -- itself               -> LambdaFormInfo -- Its info               -> RepArity       -- Number of available arguments-              -> RepArity       -- Number of them being void arguments+                                -- (including void args)               -> CgLoc          -- Passed in from cgIdApp so that we can                                 -- handle let-no-escape bindings and self-recursive                                 -- tail calls using the same data constructor,@@ -553,19 +552,22 @@               -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call               -> CallMethod -getCallMethod cfg _ id _  n_args v_args _cg_loc (Just (self_loop_id, block_id, args))+getCallMethod cfg _ id _  n_args _cg_loc (Just self_loop)   | stgToCmmLoopification cfg-  , id == self_loop_id-  , args `lengthIs` (n_args - v_args)+  , MkSelfLoopInfo+    { sli_id = loop_id, sli_arity = arity+    , sli_header_block = blk_id, sli_registers = arg_regs+    } <- self_loop+  , id == loop_id+  , n_args == arity   -- If these patterns match then we know that:   --   * loopification optimisation is turned on   --   * function is performing a self-recursive call in a tail position-  --   * number of non-void parameters of the function matches functions arity.-  -- See Note [Self-recursive tail calls] and Note [Void arguments in-  -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details-  = JumpToIt block_id args+  --   * number of parameters matches the function's arity.+  -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr for more details+  = JumpToIt blk_id arg_regs -getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info+getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info   | n_args == 0 -- No args at all   && not (profileIsProfiling (stgToCmmProfile cfg))      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm@@ -573,16 +575,16 @@   | n_args < arity = SlowCall        -- Not enough args   | otherwise      = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info   = assert (n_args == 0) ReturnIt -getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info   = assert (n_args == 0) ReturnIt     -- n_args=0 because it'd be ill-typed to apply a saturated     --          constructor application to anything  getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)-              n_args _v_args _cg_loc _self_loop_info+              n_args _cg_loc _self_loop_info    | Just sig <- idTagSig_maybe id   , isTaggedSig sig -- Infered to be already evaluated by Tag Inference@@ -620,7 +622,7 @@                 updatable) 0  -- Imported(Unknown) Ids-getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info+getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info   | n_args == 0   , Just sig <- idTagSig_maybe id   , isTaggedSig sig -- Infered to be already evaluated by Tag Inference@@ -637,14 +639,14 @@       EnterIt   -- Not a function  -- TODO: Redundant with above match?--- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+-- getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info --   = assertPpr (n_args == 0) (ppr name <+> ppr n_args) --     EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info+getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info   = JumpToIt blk_id lne_regs -getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"+getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method"  ----------------------------------------------------------------------------- --              Data types for closure information

@@ -50,8 +50,9 @@   , stgToCmmFastPAPCalls   :: !Bool              -- ^   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled   , stgToCmmEagerBlackHole :: !Bool              -- ^-  , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See note [Mapping-                                                 -- Info Tables to Source Positions]+  , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions]+  , stgToCmmInfoTableMapWithFallback :: !Bool    -- ^ Include info tables with fallback source locations in the info table map+  , stgToCmmInfoTableMapWithStack :: !Bool       -- ^ Include info tables for STACK closures in the info table map   , stgToCmmOmitYields     :: !Bool              -- ^ true means omit heap checks when no allocation is performed   , stgToCmmOmitIfPragmas  :: !Bool              -- ^ true means don't generate interface programs (implied by -O0)   , stgToCmmPIC            :: !Bool              -- ^ true if @-fPIC@

@@ -1002,8 +1002,7 @@         fun            = idInfoToAmode fun_info         lf_info        = cg_lf         fun_info         n_args         = length args-        v_args         = length $ filter (isZeroBitTy . stgArgType) args-    case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of+    case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of             -- A value in WHNF, so we can just return it.         ReturnIt           | isZeroBitTy (idType fun_id) -> emitReturn []@@ -1098,12 +1097,14 @@ -- -- Implementation is spread across a couple of places in the code: -----   * FCode monad stores additional information in its reader environment---     (stgToCmmSelfLoop field). This information tells us which function can---     tail call itself in an optimized way (it is the function currently---     being compiled), what is the label of a loop header (L1 in example above)---     and information about local registers in which we should arguments---     before making a call (this would be a and b in example above).+--   * FCode monad stores additional information in its reader+--     environment (stgToCmmSelfLoop field). This `SelfLoopInfo`+--     record tells us which function can tail call itself in an+--     optimized way (it is the function currently being compiled),+--     its RepArity, what is the label of its loop header (L1 in+--     example above) and information about which local registers+--     should receive arguments when making a call (this would be a+--     and b in the example above). -- --   * Whenever we are compiling a function, we set that information to reflect --     the fact that function currently being compiled can be jumped to, instead@@ -1127,36 +1128,13 @@ --     of call will be generated. getCallMethod decides to generate a self --     recursive tail call when (a) environment stores information about --     possible self tail-call; (b) that tail call is to a function currently---     being compiled; (c) number of passed non-void arguments is equal to---     function's arity. (d) loopification is turned on via -floopification---     command-line option.+--     being compiled; (c) number of passed arguments is equal to+--     function's unarised arity. (d) loopification is turned on via+--     -floopification command-line option. -- --   * Command line option to turn loopification on and off is implemented in --     DynFlags, then passed to StgToCmmConfig for this phase.--------- Note [Void arguments in self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ State# tokens can get in the way of the loopification optimization as seen in--- #11372. Consider this:------ foo :: [a]---     -> (a -> State# s -> (# State s, Bool #))---     -> State# s---     -> (# State# s, Maybe a #)--- foo [] f s = (# s, Nothing #)--- foo (x:xs) f s = case f x s of---      (# s', b #) -> case b of---          True -> (# s', Just x #)---          False -> foo xs f s'------ We would like to compile the call to foo as a local jump instead of a call--- (see Note [Self-recursive tail calls]). However, the generated function has--- an arity of 2 while we apply it to 3 arguments, one of them being of void--- type. Thus, we mustn't count arguments of void type when checking whether--- we can turn a call into a self-recursive jump.---+  emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do

@@ -635,7 +635,7 @@   -- See Note [Self-recursive loop header].   self_loop_info <- getSelfLoop   case self_loop_info of-    Just (_, loop_header_id, _)+    Just MkSelfLoopInfo { sli_header_block = loop_header_id }         | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id     _otherwise -> return () 

@@ -42,6 +42,8 @@         Sequel(..), ReturnKind(..),         withSequel, getSequel, +        SelfLoopInfo(..),+         setTickyCtrLabel, getTickyCtrLabel,         tickScope, getTickScope, @@ -298,7 +300,7 @@                                                          -- else the RTS will deadlock _and_ also experience a severe                                                          -- performance degradation               , fcs_sequel        :: !Sequel             -- ^ What to do at end of basic block-              , fcs_selfloop      :: Maybe SelfLoopInfo  -- ^ Which tail calls can be compiled as local jumps?+              , fcs_selfloop      :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps?                                                          --   See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr               , fcs_ticky         :: !CLabel             -- ^ Destination for ticky counts               , fcs_tickscope     :: !CmmTickScope       -- ^ Tick scope for new blocks & ticks

@@ -2299,7 +2299,7 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Check to make sure that we can generate code for the specified vector type -- given the current set of dynamic flags.--- Currently these checks are specific to x86 and x86_64 architecture.+-- Currently these checks are specific to x86, x86_64 and AArch64 architectures. -- This should be fixed! -- In particular, -- 1) Add better support for other architectures! (this may require a redesign)@@ -2330,27 +2330,40 @@ checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility cfg vcat l w =   case stgToCmmVecInstrsErr cfg of-    Nothing  -> check vecWidth vcat l w  -- We are in a compatible backend-    Just err -> sorry err                -- incompatible backend, do panic+    Nothing | isX86 -> checkX86 vecWidth vcat l w+            | platformArch platform == ArchAArch64 -> checkAArch64 vecWidth+            | otherwise -> sorry "SIMD vector instructions are not supported on this architecture."+    Just err -> sorry err  -- incompatible backend, do panic   where     platform = stgToCmmPlatform cfg-    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()-    check W128 FloatVec 4 W32 | not (isSseEnabled platform) =+    isX86 = case platformArch platform of+      ArchX86_64 -> True+      ArchX86 -> True+      _ -> False+    checkX86 :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    checkX86 W128 FloatVec 4 W32 | isSseEnabled platform = return ()+                                 | otherwise =         sorry $ "128-bit wide single-precision floating point " ++                 "SIMD vector instructions require at least -msse."-    check W128 _ _ _ | not (isSse2Enabled platform) =+    checkX86 W128 _ _ _ | not (isSse2Enabled platform) =         sorry $ "128-bit wide integer and double precision " ++                 "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (stgToCmmAvx cfg) =+    checkX86 W256 FloatVec _ _ | stgToCmmAvx cfg = return ()+                               | otherwise =         sorry $ "256-bit wide floating point " ++                 "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (stgToCmmAvx2 cfg) =+    checkX86 W256 _ _ _ | not (stgToCmmAvx2 cfg) =         sorry $ "256-bit wide integer " ++                 "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (stgToCmmAvx512f cfg) =+    checkX86 W512 _ _ _ | not (stgToCmmAvx512f cfg) =         sorry $ "512-bit wide " ++                 "SIMD vector instructions require -mavx512f."-    check _ _ _ _ = return ()+    checkX86 _ _ _ _ = return ()++    checkAArch64 :: Width -> FCode ()+    checkAArch64 W256 = sorry $ "256-bit wide SIMD vector instructions are not supported."+    checkAArch64 W512 = sorry $ "512-bit wide SIMD vector instructions are not supported."+    checkAArch64 _ = return ()      vecWidth = typeWidth (vecVmmType vcat l w) 

@@ -274,24 +274,27 @@   where    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform --- | Emit info-table provenance declarations-initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub-initInfoTableProv infos itmap+-- | Emit info-table provenance declarations and track IPE stats.+--+-- Note that the stats passed to this function will (rather, should) only ever+-- contain stats for skipped STACK info tables accumulated in+-- 'generateCgIPEStub'.+initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> FCode (Maybe (IPEStats, CStub))+initInfoTableProv stats infos itmap   = do        cfg <- getStgToCmmConfig-       let ents       = convertInfoProvMap infos this_mod itmap-           info_table = stgToCmmInfoTableMap cfg-           platform   = stgToCmmPlatform     cfg-           this_mod   = stgToCmmThisModule   cfg-+       let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos+           info_table    = stgToCmmInfoTableMap cfg+           platform      = stgToCmmPlatform     cfg+           this_mod      = stgToCmmThisModule   cfg        case ents of-         [] -> return mempty+         [] -> return Nothing          _  -> do            -- Emit IPE buffer            emitIpeBufferListNode this_mod ents             -- Create the C stub which initialises the IPE map-           return (ipInitCode info_table platform this_mod)+           return (Just (stats', ipInitCode info_table platform this_mod))  -- --------------------------------------------------------------------------- -- Set the current cost centre stack

@@ -12,13 +12,14 @@  module GHC.StgToCmm.Sequel   ( Sequel(..)-  , SelfLoopInfo+  , SelfLoopInfo(..)   ) where  import GHC.Cmm.BlockId import GHC.Cmm  import GHC.Types.Id+import GHC.Types.Basic (RepArity) import GHC.Utils.Outputable  import GHC.Prelude@@ -41,5 +42,14 @@     ppr Return = text "Return"     ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b -type SelfLoopInfo = (Id, BlockId, [LocalReg])+data SelfLoopInfo = MkSelfLoopInfo+  { sli_id :: !Id+  , sli_arity :: !RepArity+    -- ^ always equal to 'idFunRepArity' of sli_id,+    -- i.e. unarised arity, including void arguments+  , sli_registers :: ![LocalReg]+    -- ^ Excludes void arguments (LocalReg is never void)+  , sli_header_block :: !BlockId+  }+ --------------------------------------------------------------------------------

@@ -7,6 +7,8 @@ -- (c) The University of Glasgow 2004-2006 -- -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}  module GHC.StgToCmm.Utils (         emitDataLits, emitRODataLits,@@ -43,7 +45,8 @@         emitUpdRemSetPush,         emitUpdRemSetPushThunk, -        convertInfoProvMap, cmmInfoTableToInfoProvEnt+        convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..),+        closureIpeStats, fallbackIpeStats, skippedIpeStats,   ) where  import GHC.Prelude hiding ( head, init, last, tail )@@ -90,6 +93,8 @@ import GHC.Data.Maybe import Control.Monad import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as I+import qualified Data.Semigroup (Semigroup(..))  -------------------------------------------------------------------------- --@@ -607,39 +612,96 @@         cn  = rtsClosureType (cit_rep cmit)     in InfoProvEnt cl cn "" this_mod Nothing +data IPEStats = IPEStats { ipe_total :: !Int+                         , ipe_closure_types :: !(I.IntMap Int)+                         , ipe_fallback :: !Int+                         , ipe_skipped :: !Int }++instance Semigroup IPEStats where+  (IPEStats a1 a2 a3 a4) <> (IPEStats b1 b2 b3 b4) = IPEStats (a1 + b1) (I.unionWith (+) a2 b2) (a3 + b3) (a4 + b4)++instance Monoid IPEStats where+  mempty = IPEStats 0 I.empty 0 0++fallbackIpeStats :: IPEStats+fallbackIpeStats = mempty { ipe_total = 1, ipe_fallback = 1 }++closureIpeStats :: Int -> IPEStats+closureIpeStats t = mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 }++skippedIpeStats :: IPEStats+skippedIpeStats = mempty { ipe_skipped = 1 }++instance Outputable IPEStats where+  ppr = pprIPEStats++pprIPEStats :: IPEStats -> SDoc+pprIPEStats (IPEStats{..}) =+  vcat $ [ text "Tables with info:" <+> ppr ipe_total+         , text "Tables with fallback:" <+> ppr ipe_fallback+         , text "Tables skipped:" <+> ppr ipe_skipped+         ] ++ [ text "Info(" <> ppr k <> text "):" <+> ppr n | (k, n) <- I.assocs ipe_closure_types ]+ -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenance table.-convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]-convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =-  map (\cmit ->-    let cl = cit_lbl cmit+--+-- The initial stats given to this function will (or should) only contain stats+-- for stack info tables skipped during 'generateCgIPEStub'. As the fold+-- progresses, counts of tables per closure type will be accumulated.+convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])+convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) initStats cmits =+    foldl' convertInfoProvMap' (initStats, []) cmits+  where+    convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])+    convertInfoProvMap' (!stats, acc) cmit = do+      let+        cl = cit_lbl cmit         cn  = rtsClosureType (cit_rep cmit)          tyString :: Outputable a => a -> String         tyString = renderWithContext defaultSDocContext . ppr -        lookupClosureMap :: Maybe InfoProvEnt+        lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)         lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of-                                Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)+                                Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan))                                 Nothing -> Nothing -        lookupDataConMap = do+        lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)+        lookupDataConMap = (closureIpeStats cn,) <$> do             UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation             -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do             (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique             -- Lookup is linear but lists will be small (< 100)-            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))+            return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))) +        lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt)         lookupInfoTableToSourceLocation = do             sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap-            return $ InfoProvEnt cl cn "" this_mod sourceNote+            return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote))          -- This catches things like prim closure types and anything else which doesn't have a         -- source location-        simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit+        simpleFallback =+          if stgToCmmInfoTableMapWithFallback cfg then+            -- Create a default entry with fallback IPE data+            Just (fallbackIpeStats, cmmInfoTableToInfoProvEnt this_mod cmit)+          else+            -- If we are omitting tables with fallback info+            -- (-fno-info-table-map-with-fallback was given), do not create an+            -- entry+            Nothing -  in-    if (isStackRep . cit_rep) cmit then-      fromMaybe simpleFallback lookupInfoTableToSourceLocation-    else-      fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns+        trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])+        trackSkipped Nothing =+          (stats Data.Semigroup.<> skippedIpeStats, acc)+        trackSkipped (Just (s, !c)) =+          (stats Data.Semigroup.<> s, c:acc)++      trackSkipped $+        if (isStackRep . cit_rep) cmit then+          -- Note that we should have already skipped STACK info tables if+          -- necessary in 'generateCgIPEStub', so we should not need to worry+          -- about doing that here.+          fromMaybe simpleFallback (Just <$> lookupInfoTableToSourceLocation)+        else+          fromMaybe simpleFallback (Just <$> firstJust lookupDataConMap lookupClosureMap)

@@ -47,6 +47,14 @@ import Data.Char (isSpace) import qualified Control.Exception as Exception +import GHC.Builtin.Types+import Language.Haskell.Syntax.Basic+import GHC.Types.Name+import GHC.StgToJS.Ids+import GHC.Core.DataCon+import GHC.JS.Unsat.Syntax+import GHC.Data.FastString+ -- | Retrieve library directories provided by the @UnitId@ in @UnitState@ getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us@@ -71,6 +79,26 @@ commonCppDefs_vanilla  = genCommonCppDefs False commonCppDefs_profiled = genCommonCppDefs True +-- | Generate macros MK_TUP* for tuples sized 2+.+genMkTup :: Bool -> Int -> ByteString+genMkTup profiling n = mconcat+  [ "#define MK_TUP", sn                                                          -- #define MK_TUPn+  , "(", B.intercalate "," xs, ")"                                                -- (x1,x2,...)+  , "(h$c", sn, "("                                                               -- (h$cn(+  , bytesFS symbol, ","                                                           -- h$ghczmprimZCGHCziTupleziPrimziZnT_con_e,                                                                        -- ,+  , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs                            -- (x1),(x2),(...)+  , if profiling then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" else "" -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM+  , "))\n"                                                                        -- ))\n+  ]+  where+    xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int])+    sn = Char8.pack $ show n+    TxtI symbol = makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod+    name = tupleDataConName Boxed n+    mod = case nameModule_maybe name of+      Just m -> m+      Nothing -> error "Tuple constructor is missing a module"+ -- | Generate CPP Definitions depending on a profiled or normal build. This -- occurs at link time. genCommonCppDefs :: Bool -> ByteString@@ -87,29 +115,7 @@     in mconcat (closure_defs ++ thread_defs)    -- low-level heap object manipulation macros-  , if profiling-      then mconcat-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"-        ]-      else mconcat-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n"-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n"-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n"-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n"-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n"-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n"-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n"-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n"-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n"-        ]+  , mconcat (map (genMkTup profiling) [2..10])    , "#define TUP2_1(x) ((x).d1)\n"   , "#define TUP2_2(x) ((x).d2)\n"

@@ -52,7 +52,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Type-import GHC.Tc.Validity ( checkValidCoAxBranch )+import GHC.Tc.Validity  import GHC.Core.DataCon import GHC.Core.FamInstEnv@@ -71,6 +71,7 @@ import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Env import GHC.Types.Var+import GHC.Types.Var.Set  import GHC.Builtin.Names import GHC.Builtin.Names.TH@@ -2085,6 +2086,7 @@                                            rep_lhs_tys         let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'                                     fam_tc rep_lhs_tys rep_rhs_ty+        checkFamPatBinders fam_tc (rep_tvs' ++ rep_cvs') emptyVarSet rep_lhs_tys rep_rhs_ty         -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv         checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)         newFamInst SynFamilyInst axiom

@@ -987,6 +987,12 @@                             -- Note [Swizzling the tyvars before generaliseTcTyCon]                 = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)                        , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]++    TcRnDisconnectedTyVar n+      -> mkSimpleDecorated $+           hang (text "Scoped type variable only appears non-injectively in declaration header:")+              2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n))+     TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext       -> mkSimpleDecorated $            sep [ ppDataSort data_sort <+>@@ -2135,6 +2141,8 @@       -> ErrorWithoutFlag     TcRnDifferentNamesForTyVar{}       -> ErrorWithoutFlag+    TcRnDisconnectedTyVar{}+      -> ErrorWithoutFlag     TcRnInvalidReturnKind{}       -> ErrorWithoutFlag     TcRnClassKindNotConstraint{}@@ -2752,6 +2760,8 @@       -> noHints     TcRnDifferentNamesForTyVar{}       -> noHints+    TcRnDisconnectedTyVar n+      -> [SuggestBindTyVarExplicitly n]     TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext       -> case mb_suggest_unlifted_ext of            Nothing -> noHints@@ -5994,7 +6004,7 @@     hang (text "Mismatched type name in type family instance.")        2 (vcat [ text "Expected:" <+> ppr fam_tc_name                , text "  Actual:" <+> ppr eqn_tc_name ])-  FamInstRHSOutOfScopeTyVars mb_dodgy tvs ->+  FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) ->     hang (text "Out of scope type variable" <> plural tvs          <+> pprWithCommas (quotes . ppr) tvs          <+> text "in the RHS of a family instance.")@@ -6007,13 +6017,60 @@     mk_extra = case mb_dodgy of       Nothing -> empty       Just (fam_tc, pats, dodgy_tvs) ->-        ppWhen (any (`elemVarSetByKey` dodgy_tvs) (map nameUnique tvs)) $+        ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $           hang (text "The real LHS (expanding synonyms) is:")              2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))-  FamInstLHSUnusedBoundTyVars tvs ->-    hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs-          <+> isOrAre tvs <+> text "bound by a forall,")-       2 (text "but not used in the family instance.")+  FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) ->+    vcat [ not_bound_msg, not_used_msg, dodgy_msg ]+    where++      -- Filter to only keep user-written variables,+      -- unless none were user-written in which case we report all of them+      -- (as we need to report an error).+      filter_user tvs+        = map ifiqtv+        $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs }++      (not_bound, not_used, dodgy)+        = case foldr acc_tv ([], [], []) bad_qtvs of+            (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d)++      acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of+        InvalidFamInstQTvNotUsedInRHS   -> (nb, tv : nu, d)+        InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d)+        InvalidFamInstQTvDodgy          -> (nb, nu, tv : d)++      -- Error message for type variables not bound in LHS patterns.+      not_bound_msg+        | null not_bound+        = empty+        | otherwise+        = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound+            <+> isOrAre not_bound <+> text "bound by a forall,"+              , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ]++      -- Error message for type variables bound by a forall but not used+      -- in the RHS.+      not_used_msg =+        if null not_used+        then empty+        else text "The type variable" <> plural not_used <+> pprQuotedList not_used+             <+> isOrAre not_used <+> text "bound by a forall," $$+             text "but" <+> itOrThey not_used <+>+             isOrAre not_used <> text "n't used in the family instance."++      -- Error message for dodgy type variables.+      -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity.+      dodgy_msg+        | null dodgy+        = empty+        | otherwise+        = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy+               <+> text "in the LHS of a family instance:")+             2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy+                <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns,"+               $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.")+  illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint] illegalFamilyInstanceHints = \case

@@ -137,6 +137,7 @@   , IllegalHasFieldInstance(..)   , CoverageProblem(..), FailedCoverageCondition(..)   , IllegalFamilyInstanceReason(..)+  , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..)   , InvalidAssoc(..), InvalidAssocInstance(..)   , InvalidAssocDefault(..), AssocDefaultBadArgs(..) @@ -180,7 +181,7 @@ import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.ForeignCall (CLabelString) import GHC.Types.Id.Info ( RecSelParent(..) )-import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan)+import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan) import qualified GHC.Types.Name.Occurrence as OccName import GHC.Types.Name.Reader import GHC.Types.SourceFile (HsBootOrSig(..))@@ -2262,6 +2263,13 @@   -}   TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage +  {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature,+      where the implicitly-bound type type variables can't be matched up unambiguously+      with the ones from the signature. See Note [Disconnected type variables] in+      GHC.Tc.Gen.HsType.+  -}+  TcRnDisconnectedTyVar :: !Name -> TcRnMessage+   {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature      with an invalid result kind. @@ -4547,13 +4555,46 @@         -- ^ family 'TyCon', arguments, and set of "dodgy" type variables         -- See Note [Dodgy binding sites in type family instances]         -- in GHC.Tc.Validity-      ![Name] -- ^ the out-of-scope type variables+      !(NE.NonEmpty Name) -- ^ the out-of-scope type variables    | FamInstLHSUnusedBoundTyVars-      ![Name] -- ^ the unused bound type variables+      !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables    | InvalidAssoc !InvalidAssoc   deriving Generic++-- | A quantified type variable in a type or data family equation that+-- is either not bound in any LHS patterns or not used in the RHS (or both).+data InvalidFamInstQTv+  = InvalidFamInstQTv+    { ifiqtv :: TcTyVar+    , ifiqtv_user_written :: Bool+       -- ^ Did the user write this type variable, or was introduced by GHC?+       -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@,+       -- we have a user-written @a@ but GHC introduces a kind variable @k@+       -- as well. See #23734.+    , ifiqtv_reason       :: InvalidFamInstQTvReason+      -- ^ For what reason was the quantified type variable invalid?+    }++data InvalidFamInstQTvReason+  -- | A dodgy binder, i.e. a variable that syntactically appears in+  -- LHS patterns but only in non-injective positions.+  --+  -- See Note [Dodgy binding sites in type family instances]+  -- in GHC.Tc.Validity.+  = InvalidFamInstQTvDodgy+  -- | A quantified type variable in a type or data family equation+  -- that is not bound in any LHS patterns.+  | InvalidFamInstQTvNotBoundInPats+  -- | A quantified type variable in a type or data family equation+  -- that is not used on the RHS.+  | InvalidFamInstQTvNotUsedInRHS++-- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders'+-- uses 'getSrcSpan', so this 'NamedThing' instance is convenient.+instance NamedThing InvalidFamInstQTv where+  getName = getName . ifiqtv  data InvalidAssoc   -- | An invalid associated family instance.

@@ -2562,13 +2562,14 @@                    --               ^^^^^^^^^                    -- We do it here because at this point the environment has been                    -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.-                 ; ctx_k <- kc_res_ki+                 ; res_kind :: ContextKind <- kc_res_ki +                  -- Work out extra_arity, the number of extra invisible binders from                  -- the kind signature that should be part of the TyCon's arity.                  -- See Note [Arity inference in kcCheckDeclHeader_sig]                  ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs-                       invis_arity = case ctx_k of+                       invis_arity = case res_kind of                           AnyKind    -> n_invis_tcbs -- No kind signature, so make all the invisible binders                                                      -- the signature into part of the arity of the TyCon                           OpenKind   -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the@@ -2582,12 +2583,9 @@                                                             , ppr invis_arity, ppr invis_tcbs                                                             , ppr n_invis_tcbs ] -                 -- Unify res_ki (from the type declaration) with the residual kind from-                 -- the kind signature. Don't forget to apply the skolemising 'subst' first.-                 ; case ctx_k of-                      AnyKind -> return ()   -- No signature-                      _ -> do { res_ki <- newExpectedKind ctx_k-                              ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }+                 -- Unify res_ki (from the type declaration) with+                 -- sig_res_kind', the residual kind from the kind signature.+                 ; checkExpectedResKind sig_res_kind' res_kind                   -- Add more binders for data/newtype, so the result kind has no arrows                  -- See Note [Datatype return kinds]@@ -2610,6 +2608,7 @@         ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs         ; let implicit_prs = implicit_nms `zip` implicit_tvs         ; checkForDuplicateScopedTyVars implicit_prs+        ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs          -- Swizzle the Names so that the TyCon uses the user-declared implicit names         -- E.g  type T :: k -> Type@@ -2623,11 +2622,11 @@               all_tv_prs             = mkTyVarNamePairs (binderVars swizzled_tcbs)          ; traceTc "kcCheckDeclHeader swizzle" $ vcat-          [ text "implicit_prs = "  <+> ppr implicit_prs-          , text "implicit_nms = "  <+> ppr implicit_nms-          , text "hs_tv_bndrs = "  <+> ppr hs_tv_bndrs-          , text "all_tcbs = "      <+> pprTyVars (binderVars all_tcbs)-          , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs)+          [ text "sig_tcbs ="       <+> ppr sig_tcbs+          , text "implicit_prs ="   <+> ppr implicit_prs+          , text "hs_tv_bndrs ="    <+> ppr hs_tv_bndrs+          , text "all_tcbs ="       <+> pprTyVars (binderVars all_tcbs)+          , text "swizzled_tcbs ="  <+> pprTyVars (binderVars swizzled_tcbs)           , text "tycon_res_kind =" <+> ppr tycon_res_kind           , text "swizzled_kind ="  <+> ppr swizzled_kind ] @@ -2648,6 +2647,27 @@           ]         ; return tc } +-- | Check the result kind annotation on a type constructor against+-- the corresponding section of the standalone kind signature.+-- Drops invisible binders that interfere with unification.+checkExpectedResKind :: TcKind       -- ^ the result kind from the separate kind signature+                     -> ContextKind  -- ^ the result kind from the declaration header+                     -> TcM ()+checkExpectedResKind _ AnyKind+  = return ()  -- No signature in the declaration header+checkExpectedResKind sig_kind res_ki+  = do { actual_res_ki <- newExpectedKind res_ki++       ; let -- Drop invisible binders from sig_kind until they match up+             -- with res_ki.  By analogy with checkExpectedKind.+             n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki+             n_sig_invis_bndrs = invisibleTyBndrCount sig_kind+             n_to_inst         = n_sig_invis_bndrs - n_res_invis_bndrs++             (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind++       ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki }+ matchUpSigWithDecl   :: Name                        -- Name of the type constructor for error messages   -> [TcTyConBinder]             -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature@@ -2985,6 +3005,25 @@ *                                                                      * ********************************************************************* -} +checkForDisconnectedScopedTyVars :: TyConFlavour TyCon -> [TcTyConBinder]+                                 -> [(Name,TcTyVar)] -> TcM ()+-- See Note [Disconnected type variables]+-- `scoped_prs` is the mapping gotten by unifying+--    - the standalone kind signature for T, with+--    - the header of the type/class declaration for T+checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs+  = when (needsEtaExpansion flav) $+         -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables]+    mapM_ report_disconnected (filterOut ok scoped_prs)+  where+    sig_tvs = mkVarSet (binderVars sig_tcbs)+    ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs++    report_disconnected :: (Name,TcTyVar) -> TcM ()+    report_disconnected (nm, _)+      = setSrcSpan (getSrcSpan nm) $+        addErrTc $ TcRnDisconnectedTyVar nm+ checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates -- E.g. data SameKind (a::k) (b::k)@@ -3014,6 +3053,64 @@       = setSrcSpan (getSrcSpan n2) $         addErrTc $ TcRnDifferentNamesForTyVar n1 n2 ++{- Note [Disconnected type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note applies when kind-checking the header of a type/class decl that has+a separate, standalone kind signature.  See #24083.++Consider:+   type S a = Type++   type C :: forall k. S k -> Constraint+   class C (a :: S kk) where+     op :: ...kk...++Note that the class has a separate kind signature, so the elaborated decl should+look like+   class C @kk (a :: S kk) where ...++But how can we "connect up" the scoped variable `kk` with the skolem kind from the+standalone kind signature for `C`?  In general we do this by unifying the two.+For example+   type T k = (k,Type)+   type W :: forall k. T k -> Type+   data W (a :: (x,Type)) = ..blah blah..++When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k)+from the standalone kind signature.  Of course, unification looks through synonyms+so we end up with the mapping [x :-> k] that connects the scoped type variable `x`+with the kind from the signature.++But in our earlier example this unification is ineffective -- because `S` is a+phantom synonym that just discards its argument.  So our plan is this:++  if matchUpSigWithDecl fails to connect `kk with `k`, by unification,+  we give up and complain about a "disconnected" type variable.++See #24083 for dicussion of alternatives, none satisfactory.  Also the fix is+easy: just add an explicit `@kk` parameter to the declaration, to bind `kk`+explicitly, rather than binding it implicitly via unification.++(DTV1) We only want to make this check when there /are/ scoped type variables; and+  that is determined by needsEtaExpansion.  Examples:++     type C :: x -> y -> Constraint+     class C a :: b -> Constraint where { ... }+     -- The a,b scope over the "..."++     type D :: forall k. k -> Type+     data family D :: kk -> Type+     -- Nothing for `kk` to scope over!++  In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will+  return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty.  So if we do+  the check-for-disconnected-tyvars check we'll complain that `kk` is not bound+  to one of `all_tcbs` (see #24083, comments about the `singletons` package).++  The scoped-tyvar stuff is needed precisely for data/class/newtype declarations,+  where needsEtaExpansion is True.+-}  {- ********************************************************************* *                                                                      *

@@ -1945,8 +1945,8 @@                         -- False <=> value namespace            -> String -> TcM (Maybe TH.Name) lookupName is_type_name s-  = do { mb_nm <- lookupSameOccRn_maybe rdr_name-       ; return (fmap reifyName mb_nm) }+  = do { mb_nm <- lookupOccRn_maybe rdr_name+       ; return (fmap (reifyName . greName) mb_nm) }   where     th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M' @@ -1961,6 +1961,12 @@         | otherwise         = if isLexCon occ_fs then mkDataOccFS occ_fs                              else mkVarOccFS  occ_fs+                               -- NB: when we pick the variable namespace, we+                               -- might well obtain an identifier in a record+                               -- field namespace, as lookupOccRn_maybe looks in+                               -- record field namespaces when looking up variables.+                               -- This ensures we can look up record fields using+                               -- this function (#24293).      rdr_name = case TH.nameModule th_name of                  Nothing  -> mkRdrUnqual occ

@@ -1660,12 +1660,16 @@              swap_for_size = typesSize fun_args2 > typesSize fun_args1               -- See Note [Orienting TyFamLHS/TyFamLHS]-             swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&+             meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1+             meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2+             swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs                                   -- See Note [Put touchable variables on the left]-                                  not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)                                   -- This second check is just to avoid unfruitful swapping -       ; if swap_for_rewriting || swap_for_size+         -- It's important that we don't flip-flop (#T24134)+         -- So swap_for_rewriting "wins", and we only try swap_for_size+         -- if swap_for_rewriting doesn't care either way+       ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size)          then finish_with_swapping          else finish_without_swapping } }   where@@ -1884,7 +1888,9 @@               -- If we had F a ~ G (F a), which gives an occurs check,               -- then swap it to G (F a) ~ F a, which does not               -- However `swap_for_size` above will orient it with (G (F a)) on-              -- the left anwyway, so the next four lines of code are redundant+              -- the left anwyway.  `swap_for_rewriting` "wins", but that doesn't+              -- matter: in the occurs check case swap_for_rewriting will be moot.+              -- TL;DR: the next four lines of code are redundant               -- I'm leaving them here in case they become relevant again --              | TyFamLHS {} <- lhs --              , Just can_rhs <- canTyFamEqLHS_maybe rhs

@@ -48,6 +48,7 @@ import GHC.Tc.TyCl.Utils import GHC.Tc.TyCl.Class import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )+import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM ) import GHC.Tc.Deriv (DerivInfo(..)) import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) )@@ -84,6 +85,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.SourceFile+import GHC.Types.TypeEnv import GHC.Types.Unique import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt@@ -93,6 +95,7 @@ import GHC.Data.List.SetOps( minusList, equivClasses )  import GHC.Unit+import GHC.Unit.Module.ModDetails  import GHC.Utils.Outputable import GHC.Utils.Panic@@ -108,6 +111,7 @@ import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE+import Data.Traversable ( for ) import Data.Tuple( swap )  {-@@ -193,12 +197,13 @@            -- Step 1: Typecheck the standalone kind signatures and type/class declarations        ; traceTc "---- tcTyClGroup ---- {" empty        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))-       ; (tyclss, data_deriv_info, kindless) <-+       ; (tyclss_with_validity_infos, data_deriv_info, kindless) <-            tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]            do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs               ; tcTyClDecls tyclds kisig_env role_annots }-+       ; let tyclss = map fst tyclss_with_validity_infos            -- Step 1.5: Make sure we don't have any type synonym cycles+        ; traceTc "Starting synonym cycle check" (ppr tyclss)        ; home_unit <- hsc_home_unit <$> getTopEnv        ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds@@ -209,7 +214,16 @@            -- Do it before Step 3 (adding implicit things) because the latter            -- expects well-formed TyCons        ; traceTc "Starting validity check" (ppr tyclss)-       ; tyclss <- concatMapM checkValidTyCl tyclss+       ; tyclss <- tcExtendTyConEnv tyclss $+           -- NB: put the TyCons in the environment for validity checking,+           -- as we might look them up in checkTyConConsistentWithBoot.+           -- See Note [TyCon boot consistency checking].+          fmap concat . for tyclss_with_validity_infos $ \ (tycls, ax_validity_infos) ->+          do { tcAddFamInstCtxt (text "type family") (tyConName tycls) $+               tcAddClosedTypeFamilyDeclCtxt tycls $+                 mapM_ (checkTyFamEqnValidityInfo tycls) ax_validity_infos+             ; checkValidTyCl tycls }+        ; traceTc "Done validity check" (ppr tyclss)        ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss            -- See Note [Check role annotations in a second pass]@@ -239,7 +253,7 @@   :: [LTyClDecl GhcRn]   -> KindSigEnv   -> RoleAnnotEnv-  -> TcM ([TyCon], [DerivInfo], NameSet)+  -> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet) tcTyClDecls tyclds kisig_env role_annots   = do {    -- Step 1: kind-check this group and returns the final             -- (possibly-polymorphic) kind of each TyCon and Class@@ -259,10 +273,11 @@             -- NB: We have to be careful here to NOT eagerly unfold             -- type synonyms, as we have not tested for type synonym             -- loops yet and could fall into a black hole.-       ; fixM $ \ ~(rec_tyclss, _, _) -> do+       ; fixM $ \ ~(rec_tyclss_with_validity_infos, _, _) -> do            { tcg_env <- getGblEnv                  -- Forced so we don't retain a reference to the TcGblEnv            ; let !src  = tcg_src tcg_env+                 rec_tyclss = map fst rec_tyclss_with_validity_infos                  roles = inferRoles src role_annots rec_tyclss                   -- Populate environment with knot-tied ATyCon for TyCons@@ -2515,23 +2530,26 @@ datatypes are just a new sub-class thereof. -} -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) tcTyClDecl roles_info (L loc decl)   | Just thing <- wiredInNameTyThing_maybe (tcdName decl)   = case thing of -- See Note [Declarations for wired-in things]-      ATyCon tc -> return (tc, wiredInDerivInfo tc decl)+      ATyCon tc -> return ((tc, []), wiredInDerivInfo tc decl)       _ -> pprPanic "tcTyClDecl" (ppr thing)    | otherwise   = setSrcSpanA loc $ tcAddDeclCtxt decl $     do { traceTc "---- tcTyClDecl ---- {" (ppr decl)-       ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl+       ; (tc_vi@(tc, _), deriv_infos) <- tcTyClDecl1 Nothing roles_info decl        ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)-       ; return (tc, deriv_infos) }+       ; return (tc_vi, deriv_infos) }  noDerivInfos :: a -> (a, [DerivInfo]) noDerivInfos a = (a, []) +noEqnValidityInfos :: a -> (a, [TyFamEqnValidityInfo])+noEqnValidityInfos a = (a, [])+ wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] wiredInDerivInfo tycon decl   | DataDecl { tcdDataDefn = dataDefn } <- decl@@ -2546,7 +2564,7 @@ wiredInDerivInfo _ _ = []    -- "type family" declarations-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })   = fmap noDerivInfos $     tcFamDecl1 parent fd@@ -2556,7 +2574,7 @@             (SynDecl { tcdLName = L _ tc_name                      , tcdRhs   = rhs })   = assert (isNothing _parent )-    fmap noDerivInfos $+    fmap ( noDerivInfos . noEqnValidityInfos ) $     tcTySynRhs roles_info tc_name rhs    -- "data/newtype" declaration@@ -2564,6 +2582,7 @@             decl@(DataDecl { tcdLName = L _ tc_name                            , tcdDataDefn = defn })   = assert (isNothing _parent) $+    fmap (\(tc, deriv_info) -> ((tc, []), deriv_info)) $     tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn  tcTyClDecl1 _parent roles_info@@ -2577,7 +2596,7 @@   = assert (isNothing _parent) $     do { clas <- tcClassDecl1 roles_info class_name hs_ctxt                               meths fundeps sigs ats at_defs-       ; return (noDerivInfos (classTyCon clas)) }+       ; return (noDerivInfos $ noEqnValidityInfos (classTyCon clas)) }   {- *********************************************************************@@ -2665,14 +2684,14 @@  {- Note [Associated type defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- The following is an example of associated type defaults:-             class C a where-               data D a -               type F a b :: *-               type F a b = [a]        -- Default+  class C a where+    data D a +    type F a b :: *+    type F a b = [a]        -- Default+ Note that we can get default definitions only for type families, not data families. -}@@ -2706,7 +2725,8 @@                                           (at_def_tycon at_def) [at_def])                         emptyNameEnv at_defs -    tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at+    tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at+                  ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos                   ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)                                   `orElse` []                   ; atd <- tcDefaultAssocDecl fam_tc at_defs@@ -2714,9 +2734,9 @@  ------------------------- tcDefaultAssocDecl ::-     TyCon                                       -- ^ Family TyCon (not knot-tied)-  -> [LTyFamDefltDecl GhcRn]                     -- ^ Defaults-  -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS+     TyCon                                             -- ^ Family TyCon (not knot-tied)+  -> [LTyFamDefltDecl GhcRn]                           -- ^ Defaults+  -> TcM (Maybe (KnotTied Type, TyFamEqnValidityInfo)) -- ^ Type checked RHS tcDefaultAssocDecl _ []   = return Nothing  -- No default declaration @@ -2756,8 +2776,9 @@        -- at an associated type. But this would be wrong, because an associated        -- type default LHS can mention *different* type variables than the        -- enclosing class. So it's treated more as a freestanding beast.-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated-                                      outer_bndrs hs_pats hs_rhs_ty+       ; (qtvs, non_user_tvs, pats, rhs_ty)+           <- tcTyFamInstEqnGuts fam_tc NotAssociated+                outer_bndrs hs_pats hs_rhs_ty         ; let fam_tvs = tyConTyVars fam_tc        ; traceTc "tcDefaultAssocDecl 2" (vcat@@ -2776,7 +2797,13 @@                        -- simply create an empty substitution and let GHC fall                        -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt.                        -- See Note [Type-checking default assoc decls].-       ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats)++       ; pure $ Just ( substTyUnchecked subst rhs_ty+                     , VI { vi_loc          = locA loc+                          , vi_qtvs         = qtvs+                          , vi_non_user_tvs = non_user_tvs+                          , vi_pats         = pats+                          , vi_rhs          = rhs_ty } )            -- We perform checks for well-formedness and validity later, in            -- GHC.Tc.Validity.checkValidAssocTyFamDeflt.      }@@ -2879,7 +2906,7 @@ *                                                                      * ********************************************************************* -} -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon+tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM (TyCon, [TyFamEqnValidityInfo]) tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info                               , fdLName = tc_lname@(L _ tc_name)                               , fdResultSig = L _ sig@@ -2908,7 +2935,7 @@                               (resultVariableName sig)                               (DataFamilyTyCon tc_rep_name)                               parent inj-  ; return tycon }+  ; return (tycon, []) }    | OpenTypeFamily <- fam_info   = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do@@ -2919,7 +2946,7 @@   ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind                                (resultVariableName sig) OpenSynFamilyTyCon                                parent inj'-  ; return tycon }+  ; return (tycon, []) }    | ClosedTypeFamily mb_eqns <- fam_info   = -- Closed type families are a little tricky, because they contain the definition@@ -2939,10 +2966,11 @@          -- but eqns might be empty in the Just case as well        ; case mb_eqns of            Nothing   ->-               return $ mkFamilyTyCon tc_name tc_bndrs res_kind-                                      (resultVariableName sig)-                                      AbstractClosedSynFamilyTyCon parent-                                      inj'+              let tc = mkFamilyTyCon tc_name tc_bndrs res_kind+                                     (resultVariableName sig)+                                     AbstractClosedSynFamilyTyCon parent+                                     inj'+              in return (tc, [])            Just eqns -> do {           -- Process the equations, creating CoAxBranches@@ -2951,7 +2979,8 @@                                    False {- this doesn't matter here -}                                    ClosedTypeFamilyFlavour -       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns+       ; (branches, axiom_validity_infos) <-+           unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns          -- Do not attempt to drop equations dominated by earlier          -- ones here; in the case of mutual recursion with a data          -- type, we get a knot-tying failure.  Instead we check@@ -2971,7 +3000,7 @@          -- We check for instance validity later, when doing validity          -- checking for the tycon. Exception: checking equations          -- overlap done by dropDominatedAxioms-       ; return fam_tc } }+       ; return (fam_tc, axiom_validity_infos) } }  #if __GLASGOW_HASKELL__ <= 810   | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker@@ -3183,7 +3212,7 @@  -------------------------- tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn-               -> TcM (KnotTied CoAxBranch)+               -> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo) -- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families -- (typechecked here) have TyFamInstEqns @@ -3202,14 +3231,23 @@         ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats -       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo-                                      outer_bndrs hs_pats hs_rhs_ty+       ; (qtvs, non_user_tvs, pats, rhs_ty)+           <- tcTyFamInstEqnGuts fam_tc mb_clsinfo+                outer_bndrs hs_pats hs_rhs_ty        -- Don't print results they may be knot-tied        -- (tcFamInstEqnGuts zonks to Type)-       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty-                              (map (const Nominal) qtvs)-                              (locA loc)) } +       ; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty+                    (map (const Nominal) qtvs)+                    (locA loc)+             vi = VI { vi_loc          = locA loc+                     , vi_qtvs         = qtvs+                     , vi_non_user_tvs = non_user_tvs+                     , vi_pats         = pats+                     , vi_rhs          = rhs_ty }++       ; return (ax, vi) }+ checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats =   do { -- Ensure that each equation's type constructor is for the right@@ -3292,11 +3330,13 @@ -}  --------------------------+ tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo                    -> HsOuterFamEqnTyVarBndrs GhcRn     -- Implicit and explicit binders                    -> HsTyPats GhcRn                    -- Patterns                    -> LHsType GhcRn                     -- RHS-                   -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs)+                   -> TcM ([TyVar], TyVarSet, [TcType], TcType)+                       -- (tyvars, non_user_tvs, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty   = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats)@@ -3350,11 +3390,12 @@                     ; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) }        ; doNotQuantifyTyVars dvs_rhs err_ctx -       ; (final_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $+       ; (final_tvs, non_user_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $          runZonkBndrT (zonkTyBndrsX final_tvs) $ \ final_tvs ->-           do { lhs_ty    <- zonkTcTypeToTypeX lhs_ty-              ; rhs_ty    <- zonkTcTypeToTypeX rhs_ty-              ; return (final_tvs, lhs_ty, rhs_ty) }+           do { lhs_ty       <- zonkTcTypeToTypeX lhs_ty+              ; rhs_ty       <- zonkTcTypeToTypeX rhs_ty+              ; non_user_tvs <- traverse lookupTyVarX qtvs+              ; return (final_tvs, non_user_tvs, lhs_ty, rhs_ty) }         ; let pats = unravelFamInstPats lhs_ty              -- Note that we do this after solveEqualities@@ -3365,7 +3406,7 @@                  -- Don't try to print 'pats' here, because lhs_ty involves                  -- a knot-tied type constructor, so we get a black hole -       ; return (final_tvs, pats, rhs_ty) }+       ; return (final_tvs, mkVarSet non_user_tvs, pats, rhs_ty) }  checkFamTelescope :: TcLevel                   -> HsOuterFamEqnTyVarBndrs GhcRn@@ -4179,7 +4220,7 @@ certainly degrade error messages a bit, though. -} --- ^ From information about a source datacon definition, extract out+-- | From information about a source datacon definition, extract out -- what the universal variables and the GADT equalities should be. -- See Note [mkGADTVars]. mkGADTVars :: [TyVar]    -- ^ The tycon vars@@ -4241,7 +4282,7 @@               eqs'     = (t_tv', r_ty) : eqs        | otherwise-      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)+      = choose (t_tv:univs) eqs t_sub r_sub t_tvs        -- choose an appropriate name for a univ tyvar.       -- This *must* preserve the Unique of the result tv, so that we@@ -4327,6 +4368,7 @@     recoverM recovery_code     $     do { traceTc "Starting validity for tycon" (ppr tc)        ; checkValidTyCon tc+       ; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking]        ; traceTc "Done validity for tycon" (ppr tc)        ; return [tc] }   where@@ -4403,6 +4445,49 @@ --        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T -- Here we do not complain about f1,f2 because they are existential +-- | Check that a 'TyCon' is consistent with the one in the hs-boot file,+-- if any.+--+-- See Note [TyCon boot consistency checking].+checkTyConConsistentWithBoot :: TyCon -> TcM ()+checkTyConConsistentWithBoot tc =+  do { gbl_env <- getGblEnv+     ; let name          = tyConName tc+           real_thing    = ATyCon tc+           boot_info     = tcg_self_boot gbl_env+           boot_type_env = case boot_info of+             NoSelfBoot            -> emptyTypeEnv+             SelfBoot boot_details -> md_types boot_details+           m_boot_info   = lookupTypeEnv boot_type_env name+     ; case m_boot_info of+         Nothing         -> return ()+         Just boot_thing -> checkBootDeclM HsBoot boot_thing real_thing+     }++{- Note [TyCon boot consistency checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to throw an error when A.hs and A.hs-boot define a TyCon inconsistently,+e.g.++  -- A.hs-boot+  type D :: Type+  data D++  -- A.hs+  data D (k :: Type) = MkD++Here A.D and A[boot].D have different kinds, so we must error. In addition, we+must error eagerly, lest other parts of the compiler witness this inconsistency+(which was the subject of #16127). To achieve this, we call+checkTyConIsConsistentWithBoot in checkValidTyCl, which is called in+GHC.Tc.TyCl.tcTyClGroup.++Note that, when calling checkValidTyCl, we must extend the TyCon environment.+For example, we could end up comparing the RHS of two type synonym declarations+to check they are consistent, and these RHS might mention some of the TyCons we+are validity checking, so they need to be in the environment.+-}+ checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc   | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim@@ -4665,7 +4750,7 @@           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon           -- checked here because we sometimes build invalid DataCons before           -- erroring above here-        ; when debugIsOn $+        ; when debugIsOn $ whenNoErrs $           massertPpr (checkDataConTyVars con) $           ppr con $$  ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) @@ -4837,14 +4922,19 @@                         -- since there is no possible ambiguity (#10020)               -- Check that any default declarations for associated types are valid-           ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) ->+           ; whenIsJust m_dflt_rhs $ \ (_, at_validity_info) ->              case at_validity_info of-               NoATVI -> pure ()-               ATVI loc pats ->+               NoVI -> pure ()+               VI { vi_loc          = loc+                  , vi_qtvs         = qtvs+                  , vi_non_user_tvs = non_user_tvs+                  , vi_pats         = pats+                  , vi_rhs          = orig_rhs } ->                  setSrcSpan loc $                  tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $                  do { checkValidAssocTyFamDeflt fam_tc pats-                    ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }}+                    ; checkFamPatBinders fam_tc qtvs non_user_tvs pats orig_rhs+                    ; checkValidTyFamEqn fam_tc pats orig_rhs }}         where           fam_tvs = tyConTyVars fam_tc 

@@ -4,7 +4,6 @@ -}  - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.TyCl.Build (

@@ -606,11 +606,13 @@          -- (1) do the work of verifying the synonym group          -- For some reason we don't have a location for the equation          -- itself, so we make do with the location of family name-       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo-                                        (L (na2la $ getLoc fam_lname) eqn)+       ; (co_ax_branch, co_ax_validity_info)+          <- tcTyFamInstEqn fam_tc mb_clsinfo+                (L (na2la $ getLoc fam_lname) eqn)           -- (2) check for validity        ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch+       ; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info        ; checkValidCoAxBranch fam_tc co_ax_branch           -- (3) construct coercion axiom@@ -711,7 +713,7 @@           -- See [Arity of data families] in GHC.Core.FamInstEnv        ; skol_info <- mkSkolemInfo FamInstSkol        ; let new_or_data = dataDefnConsNewOrData hs_cons-       ; (qtvs, pats, tc_res_kind, stupid_theta)+       ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta)              <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity                                     hs_ctxt hs_pats m_ksig new_or_data @@ -786,7 +788,7 @@               , text "res_kind:" <+> ppr res_kind               , text "eta_pats" <+> ppr eta_pats               , text "eta_tcbs" <+> ppr eta_tcbs ]-       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->+       ; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) ->            do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $                   -- For H98 decls, the tyvars scope                   -- over the data constructors@@ -822,13 +824,15 @@                  -- further instance might not introduce a new recursive                  -- dependency.  (2) They are always valid loop breakers as                  -- they involve a coercion.-              ; return (rep_tc, axiom) } +              ; return (rep_tc, (axiom, ax_rhs)) }+        -- Remember to check validity; no recursion to worry about here        -- Check that left-hand sides are ok (mono-types, no type families,        -- consistent instantiations, etc)        ; let ax_branch = coAxiomSingleBranch axiom        ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch+       ; checkFamPatBinders fam_tc zonked_post_eta_qtvs non_user_tvs eta_pats ax_rhs        ; checkValidCoAxBranch fam_tc ax_branch        ; checkValidTyCon rep_tc @@ -836,10 +840,10 @@              m_deriv_info = case derivs of                []    -> Nothing                preds ->-                 Just $ DerivInfo { di_rep_tc  = rep_tc+                 Just $ DerivInfo { di_rep_tc     = rep_tc                                   , di_scoped_tvs = scoped_tvs-                                  , di_clauses = preds-                                  , di_ctxt    = tcMkDataFamInstCtxt decl }+                                  , di_clauses    = preds+                                  , di_ctxt       = tcMkDataFamInstCtxt decl }         ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom        ; return (fam_inst, m_deriv_info) }@@ -913,7 +917,7 @@     -> LexicalFixity -> Maybe (LHsContext GhcRn)     -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)     -> NewOrData-    -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)+    -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType)          -- All skolem TcTyVars, all zonked so it's clear what the free vars are -- The "header" of a data family instance is the part other than -- the data constructors themselves@@ -973,14 +977,15 @@              -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]        ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted -       ; (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) <-+       ; (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) <-           liftZonkM $ do-            { final_tvs         <- zonkTcTyVarsToTcTyVars final_tvs-            ; lhs_ty            <- zonkTcType             lhs_ty-            ; master_res_kind   <- zonkTcType             master_res_kind-            ; instance_res_kind <- zonkTcType             instance_res_kind-            ; stupid_theta      <- zonkTcTypes            stupid_theta-            ; return (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) }+            { final_tvs         <- mapM zonkTcTyVarToTcTyVar final_tvs+            ; non_user_tvs      <- mapM zonkTcTyVarToTcTyVar qtvs+            ; lhs_ty            <- zonkTcType                lhs_ty+            ; master_res_kind   <- zonkTcType                master_res_kind+            ; instance_res_kind <- zonkTcType                instance_res_kind+            ; stupid_theta      <- zonkTcTypes               stupid_theta+            ; return (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) }         -- Check that res_kind is OK with checkDataKindSig.  We need to        -- check that it's ok because res_kind can come from a user-written@@ -992,7 +997,7 @@        -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]        ; let pats      = unravelFamInstPats lhs_ty -       ; return (final_tvs, pats, master_res_kind, stupid_theta) }+       ; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) }   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name

@@ -1,4 +1,3 @@- {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} 

@@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -14,6 +15,7 @@   checkValidInstance, checkValidInstHead, validDerivPred,   checkTySynRhs, checkEscapingKind,   checkValidCoAxiom, checkValidCoAxBranch,+  checkFamPatBinders, checkTyFamEqnValidityInfo,   checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,   checkTyConTelescope,   ) where@@ -82,6 +84,8 @@ import Data.Foldable import Data.Function import Data.List        ( (\\) )+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) )  {- ************************************************************************@@ -2160,28 +2164,32 @@ -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). --+-- See also the separate 'checkFamPatBinders' which performs scoping checks+-- on a type family equation.+-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a+-- separate place e.g. for associated type defaults.) checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () checkValidCoAxBranch fam_tc-                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                                , cab_lhs = typats+                    (CoAxBranch { cab_lhs = typats                                 , cab_rhs = rhs, cab_loc = loc })   = setSrcSpan loc $-    checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs+    checkValidTyFamEqn fam_tc typats rhs  -- | Do validity checks on a type family equation, including consistency -- with any enclosing class instance head, termination, and lack of -- polytypes.-checkValidTyFamEqn :: TyCon   -- ^ of the type family-                   -> [Var]   -- ^ Bound variables in the equation-                   -> [Type]  -- ^ Type patterns-                   -> Type    -- ^ Rhs+--+-- See also the separate 'checkFamPatBinders' which performs scoping checks+-- on a type family equation.+-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a+-- separate place e.g. for associated type defaults.)+checkValidTyFamEqn :: TyCon    -- ^ of the type family+                   -> [Type]   -- ^ Type patterns+                   -> Type     -- ^ Rhs                    -> TcM ()-checkValidTyFamEqn fam_tc qvs typats rhs+checkValidTyFamEqn fam_tc typats rhs   = do { checkValidTypePats fam_tc typats -         -- Check for things used on the right but not bound on the left-       ; checkFamPatBinders fam_tc qvs typats rhs-          -- Check for oversaturated visible kind arguments in a type family          -- equation.          -- See Note [Oversaturated type family equations]@@ -2283,19 +2291,47 @@       = Nothing  -----------------++-- | Perform scoping check on a type family equation.+--+-- See 'TyFamEqnValidityInfo'.+checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM ()+checkTyFamEqnValidityInfo fam_tc = \ case+  NoVI -> return ()+  VI { vi_loc          = loc+     , vi_qtvs         = qtvs+     , vi_non_user_tvs = non_user_tvs+     , vi_pats         = pats+     , vi_rhs          = rhs } ->+    setSrcSpan loc $+    checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs++-- | Check binders for a type or data family declaration.+--+-- Specifically, this function checks for:+--+--  - type variables used on the RHS but not bound (explicitly or implicitly)+--    in the LHS,+--  - variables bound by a forall in the LHS but not used in the RHS.+--+-- See Note [Check type family instance binders]. checkFamPatBinders :: TyCon-                   -> [TcTyVar]   -- Bound on LHS of family instance-                   -> [TcType]    -- LHS patterns-                   -> Type        -- RHS+                   -> [TcTyVar]   -- ^ Bound on LHS of family instance+                   -> TyVarSet    -- ^ non-user-written tyvars+                   -> [TcType]    -- ^ LHS patterns+                   -> TcType      -- ^ RHS                    -> TcM ()-checkFamPatBinders fam_tc qtvs pats rhs+checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs   = do { traceTc "checkFamPatBinders" $          vcat [ debugPprType (mkTyConApp fam_tc pats)               , ppr (mkTyConApp fam_tc pats)+              , text "rhs:" <+> ppr rhs               , text "qtvs:" <+> ppr qtvs-              , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)+              , text "rhs_fvs:" <+> ppr (fvVarSet rhs_fvs)               , text "cpt_tvs:" <+> ppr cpt_tvs-              , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]+              , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs+              , text "bad_rhs_tvs:" <+> ppr bad_rhs_tvs+              , text "bad_qtvs:" <+> ppr (map ifiqtv bad_qtvs) ]           -- Check for implicitly-bound tyvars, mentioned on the          -- RHS but not bound on the LHS@@ -2303,17 +2339,19 @@          --    data family D Int = MkD (forall (a::k). blah)          -- In both cases, 'k' is not bound on the LHS, but is used on the RHS          -- We catch the former in kcDeclHeader, and the latter right here-         -- See Note [Check type-family instance binders]+         -- See Note [Check type family instance binders]        ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs)))-                   bad_rhs_tvs+                   (map tyVarName bad_rhs_tvs)           -- Check for explicitly forall'd variable that is not bound on LHS          --    data instance forall a.  T Int = MkT Int          -- See Note [Unused explicitly bound variables in a family pattern]-         -- See Note [Check type-family instance binders]+         -- See Note [Check type family instance binders]        ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs        }   where+    rhs_fvs = tyCoFVsOfType rhs+     cpt_tvs     = tyCoVarsOfTypes pats     inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats       -- The type variables that are in injective positions.@@ -2324,18 +2362,41 @@       -- NB: It's OK to use the nondeterministic `fvVarSet` function here,       -- since the order of `inj_cpt_tvs` is never revealed in an error       -- message.-    rhs_fvs     = tyCoFVsOfType rhs-    used_tvs    = cpt_tvs `unionVarSet` fvVarSet rhs_fvs-    bad_qtvs    = filterOut (`elemVarSet` used_tvs) qtvs-                  -- Bound but not used at all-    bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)-                  -- Used on RHS but not bound on LHS++    -- Bound but not used at all+    bad_qtvs    = mapMaybe bad_qtv_maybe qtvs++    bad_qtv_maybe qtv+      | not_bound_in_pats+      = let reason+              | dodgy+              = InvalidFamInstQTvDodgy+              | used_in_rhs+              = InvalidFamInstQTvNotBoundInPats+              | otherwise+              = InvalidFamInstQTvNotUsedInRHS+        in Just $ InvalidFamInstQTv+                    { ifiqtv = qtv+                    , ifiqtv_user_written = not $ qtv `elemVarSet` non_user_tvs+                    , ifiqtv_reason = reason+                    }+      | otherwise+      = Nothing+        where+          not_bound_in_pats = not $ qtv `elemVarSet` inj_cpt_tvs+          dodgy             = not_bound_in_pats && qtv `elemVarSet` cpt_tvs+          used_in_rhs       = qtv `elemVarSet` fvVarSet rhs_fvs++    -- Used on RHS but not bound on LHS+    bad_rhs_tvs = filterOut ((`elemVarSet` inj_cpt_tvs) <||> (`elem` qtvs)) (fvVarList rhs_fvs)+     dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs      check_tvs mk_err tvs-      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $+      = for_ (NE.nonEmpty tvs) $ \ ne_tvs@(tv0 :| _) ->+        addErrAt (getSrcSpan tv0) $         TcRnIllegalInstance $ IllegalFamilyInstance $-        mk_err (map tyVarName tvs)+        mk_err ne_tvs  -- | Checks that a list of type patterns is valid in a matching (LHS) -- position of a class instances or type/data family instance.@@ -2441,7 +2502,7 @@                    | otherwise                   = BindMe  -{- Note [Check type-family instance binders]+{- Note [Check type family instance binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a type family instance, we require (of course), type variables used on the RHS are matched on the LHS. This is checked by

@@ -16,7 +16,7 @@         zonkTopDecls, zonkTopExpr, zonkTopLExpr,         zonkTopBndrs,         zonkTyVarBindersX, zonkTyVarBinderX,-        zonkTyBndrsX,+        zonkTyBndrX, zonkTyBndrsX,         zonkTcTypeToType,  zonkTcTypeToTypeX,         zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,         zonkTyVarOcc,

@@ -175,7 +175,7 @@ -- 'avails' may have several items with the same availName -- E.g  import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index)--- We want to combine these; addAvail does that+-- We want to combine these; plusAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails)   where

@@ -458,6 +458,7 @@   GhcDiagnosticCode "TcRnInvalidVisibleKindArgument"                = 20967   GhcDiagnosticCode "TcRnTooManyBinders"                            = 05989   GhcDiagnosticCode "TcRnDifferentNamesForTyVar"                    = 17370+  GhcDiagnosticCode "TcRnDisconnectedTyVar"                         = 59738   GhcDiagnosticCode "TcRnInvalidReturnKind"                         = 55233   GhcDiagnosticCode "TcRnClassKindNotConstraint"                    = 80768   GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs"                    = 91938

@@ -474,6 +474,9 @@   -}   | SuggestBindTyVarOnLhs RdrName +  {-| Suggest binding explicitly; e.g   data T @k (a :: F k) = .... -}+  | SuggestBindTyVarExplicitly Name+ -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way -- to instantiate a particular signature, where the first argument is

@@ -266,6 +266,9 @@             ppr_r = quotes $ ppr r     SuggestBindTyVarOnLhs tv       -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"+    SuggestBindTyVarExplicitly tv+      -> text "bind" <+> quotes (ppr tv)+         <+> text "explicitly with" <+> quotes (char '@' <> ppr tv)  perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

@@ -76,6 +76,7 @@         -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'         GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt,         greName, greNameSpace, greParent, greInfo,+        plusGRE, insertGRE,         forceGlobalRdrEnv, hydrateGlobalRdrEnv,         isLocalGRE, isImportedGRE, isRecFldGRE,         fieldGREInfo,@@ -573,7 +574,10 @@             -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo.     } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where+  rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ Information pertinent to the renamer about a 'Name' is stored in the fields of@@ -619,18 +623,19 @@ greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where-  rnf !_ = ()- -- | See Note [Parents] data Parent = NoParent-            | ParentIs  { par_is :: Name }+            | ParentIs  { par_is :: !Name }             deriving (Eq, Data)  instance Outputable Parent where    ppr NoParent        = empty    ppr (ParentIs n)    = text "parent:" <> ppr n +instance NFData Parent where+  rnf NoParent = ()+  rnf (ParentIs n) = rnf n+ plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _)    p2 = hasParent p1 p2@@ -933,11 +938,10 @@  -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks.--- -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs =-  strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs+  strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs  -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function.@@ -1165,6 +1169,17 @@        }     -> WhichGREs GREInfo +instance Outputable (WhichGREs info) where+  ppr SameNameSpace = text "SameNameSpace"+  ppr (RelevantGREs { includeFieldSelectors = sel+                    , lookupVariablesForFields = vars+                    , lookupTyConsAsWell = tcs_too })+    = braces $ hsep+       [ text "RelevantGREs"+       , text (show sel)+       , if vars then text "[vars]" else empty+       , if tcs_too then text "[tcs]" else empty ]+ -- | Look up as many possibly relevant 'GlobalRdrElt's as possible. pattern AllRelevantGREs :: WhichGREs GREInfo pattern AllRelevantGREs =@@ -1199,6 +1214,17 @@     -- See Note [childGREPriority].   } +instance Outputable LookupChild where+  ppr (LookupChild { wantedParent = par+                   , lookupDataConFirst = dc+                   , prioritiseParent = prio_parent })+    = braces $ hsep+        [ text "LookupChild"+        , braces (text "parent:" <+> ppr par)+        , if dc then text "[dc_first]" else empty+        , if prio_parent then text "[prio_parent]" else empty+        ]+ -- | After looking up something with the given 'NameSpace', is the resulting -- 'GlobalRdrElt' we have obtained relevant, according to the 'RelevantGREs' -- specification of which 'NameSpace's are relevant?@@ -1893,25 +1919,28 @@ -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings.-data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,-                            is_item :: ImpItemSpec }+data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec,+                            is_item :: !ImpItemSpec }                 deriving( Eq, Data ) +instance NFData ImportSpec where+  rnf = rwhnf -- All fields are strict, so we don't need to do anything+ -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec   = ImpDeclSpec {-        is_mod      :: Module,     -- ^ Module imported, e.g. @import Muggle@+        is_mod      :: !Module,     -- ^ Module imported, e.g. @import Muggle@                                    -- Note the @Muggle@ may well not be                                    -- the defining module for this thing!                                     -- TODO: either should be Module, or there                                    -- should be a Maybe UnitId here too.-        is_as       :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)-        is_qual     :: Bool,       -- ^ Was this import qualified?-        is_dloc     :: SrcSpan     -- ^ The location of the entire import declaration+        is_as       :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)+        is_qual     :: !Bool,       -- ^ Was this import qualified?+        is_dloc     :: !SrcSpan     -- ^ The location of the entire import declaration     } deriving (Eq, Data)  -- | Import Item Specification@@ -1922,8 +1951,8 @@                         -- or had a hiding list    | ImpSome {-        is_explicit :: Bool,-        is_iloc     :: SrcSpan  -- Location of the import item+        is_explicit :: !Bool,+        is_iloc     :: !SrcSpan  -- Location of the import item     }   -- ^ The import had an import list.         -- The 'is_explicit' field is @True@ iff the thing was named         -- /explicitly/ in the import specs rather

@@ -301,7 +301,7 @@                        , fr_suggestions = [] })      LookupUnusable unusable ->        let unusables' = map get_unusable unusable-           get_unusable (m, ModUnusable r) = (moduleUnit m, r)+           get_unusable (_, ModUnusable r) = r            get_unusable (_, r)             =              pprPanic "findLookupResult: unexpected origin" (ppr r)        in return (NotFound{ fr_paths = [], fr_pkg = Nothing

@@ -61,7 +61,7 @@                                            --   but the *unit* is hidden          -- | Module is in these units, but it is unusable-      , fr_unusables   :: [(Unit, UnusableUnitReason)]+      , fr_unusables   :: [UnusableUnit]        , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules       }

@@ -575,11 +575,7 @@     `seq` rnf mi_anns     `seq` rnf mi_decls     `seq` rnf mi_extra_decls-    `seq`     mi_globals-    -- NB: we already removed any potential space leaks in 'mi_globals' by-    -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'.-    -- This means we don't need to use 'rnf' here.-    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+    `seq` rnf mi_globals     `seq` rnf mi_insts     `seq` rnf mi_fam_insts     `seq` rnf mi_rules

@@ -43,6 +43,7 @@         LookupResult(..),         ModuleSuggestion(..),         ModuleOrigin(..),+        UnusableUnit(..),         UnusableUnitReason(..),         pprReason, @@ -173,8 +174,10 @@     -- (But maybe the user didn't realize), so we'll still keep track     -- of these modules.)     ModHidden-    -- | Module is unavailable because the package is unusable.-  | ModUnusable UnusableUnitReason++    -- | Module is unavailable because the unit is unusable.+  | ModUnusable !UnusableUnit+     -- | Module is public, and could have come from some places.   | ModOrigin {         -- | @Just False@ means that this module is in@@ -192,6 +195,13 @@       , fromPackageFlag :: Bool       } +-- | A unusable unit module origin+data UnusableUnit = UnusableUnit+  { uuUnit        :: !Unit               -- ^ Unusable unit+  , uuReason      :: !UnusableUnitReason -- ^ Reason+  , uuIsReexport  :: !Bool               -- ^ Is the "module" a reexport?+  }+ instance Outputable ModuleOrigin where     ppr ModHidden = text "hidden module"     ppr (ModUnusable _) = text "unusable module"@@ -236,7 +246,8 @@                     text "x: " <> ppr x $$ text "y: " <> ppr y             g Nothing x = x             g x Nothing = x-    x <> y = pprPanic "ModOrigin: hidden module redefined" $++    x <> y = pprPanic "ModOrigin: module origin mismatch" $                  text "x: " <> ppr x $$ text "y: " <> ppr y  instance Monoid ModuleOrigin where@@ -1818,21 +1829,36 @@ mkUnusableModuleNameProvidersMap unusables =     nonDetFoldUniqMap extend_modmap emptyUniqMap unusables  where-    extend_modmap (_uid, (pkg, reason)) modmap = addListTo modmap bindings+    extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings       where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]             bindings = exposed ++ hidden -            origin = ModUnusable reason-            pkg_id = mkUnit pkg+            origin_reexport =  ModUnusable (UnusableUnit unit reason True)+            origin_normal   =  ModUnusable (UnusableUnit unit reason False)+            unit = mkUnit unit_info              exposed = map get_exposed exposed_mods-            hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]+            hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] -            get_exposed (mod, Just mod') = (mod, unitUniqMap mod' origin)-            get_exposed (mod, _)         = (mod, mkModMap pkg_id mod origin)+            -- with re-exports, c:Foo can be reexported from two (or more)+            -- unusable packages:+            --  Foo -> a:Foo (unusable reason A) -> c:Foo+            --      -> b:Foo (unusable reason B) -> c:Foo+            --+            -- We must be careful to not record the following (#21097):+            --  Foo -> c:Foo (unusable reason A)+            --      -> c:Foo (unusable reason B)+            -- But:+            --  Foo -> a:Foo (unusable reason A)+            --      -> b:Foo (unusable reason B)+            --+            get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport)+            get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal)+              -- in the reexport case, we create a virtual module that doesn't+              -- exist but we don't care as it's only used as a key in the map. -            exposed_mods = unitExposedModules pkg-            hidden_mods  = unitHiddenModules pkg+            exposed_mods = unitExposedModules unit_info+            hidden_mods  = unitHiddenModules  unit_info  -- | Add a list of key/value pairs to a nested map. --

@@ -51,6 +51,7 @@         ppWhen, ppUnless, ppWhenOption, ppUnlessOption,         speakNth, speakN, speakNOf, plural, singular,         isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,+        itOrThey,         unicodeSyntax,          coloured, keyword,@@ -1523,6 +1524,15 @@ itsOrTheir :: [a] -> SDoc itsOrTheir [_] = text "its" itsOrTheir _   = text "their"++-- | 'it' or 'they', depeneding on the length of the list.+--+-- > itOrThey [x]   = text "it"+-- > itOrThey [x,y] = text "they"+-- > itOrThey []    = text "they"  -- probably avoid this+itOrThey :: [a] -> SDoc+itOrThey [_] = text "it"+itOrThey _   = text "they"   -- | Determines the form of subject appropriate for the length of a list:

@@ -457,6 +457,12 @@ #define REG_D3          d14 #define REG_D4          d15 +#define REG_XMM1        q4+#define REG_XMM2        q5++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+ /* -----------------------------------------------------------------------------    The s390x register mapping @@ -593,6 +599,8 @@  #elif defined(MACHREGS_wasm32) +#define REG_Base           0+ #define REG_R1             1 #define REG_R2             2 #define REG_R3             3@@ -624,7 +632,6 @@ #define REG_SpLim          25 #define REG_Hp             26 #define REG_HpLim          27-#define REG_CCCS           28  /* -----------------------------------------------------------------------------    The loongarch64 register mapping

@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.8.1+Version: 9.8.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -110,9 +110,9 @@                    exceptions == 0.10.*,                    semaphore-compat,                    stm,-                   ghc-boot   == 9.8.1,-                   ghc-heap   == 9.8.1,-                   ghci == 9.8.1+                   ghc-boot   == 9.8.2,+                   ghc-heap   == 9.8.2,+                   ghci == 9.8.2      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.14