ghc 9.10.2 → 9.10.3

raw patch · 45 files changed

+872/−344 lines, 45 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

• GHC/Builtin/Names.hs +5/−5
• GHC/ByteCode/Asm.hs +2/−2
• GHC/Cmm/Lexer.hs +2/−2
• GHC/CmmToAsm/AArch64/CodeGen.hs +22/−7
• GHC/CmmToAsm/Config.hs +1/−0
• GHC/CmmToAsm/Wasm/Asm.hs +1/−0
• GHC/CmmToAsm/Wasm/FromCmm.hs +26/−4
• GHC/CmmToAsm/Wasm/Types.hs +1/−0
• GHC/CmmToLlvm/Base.hs +3/−3
• GHC/CmmToLlvm/Data.hs +1/−1
• GHC/Core/Opt/SpecConstr.hs +150/−89
• GHC/Core/Predicate.hs +56/−19
• GHC/Core/TyCon.hs +1/−0
• GHC/Driver/Config/CmmToAsm.hs +1/−0
• GHC/Driver/DynFlags.hs +3/−1
• GHC/Driver/Flags.hs +2/−0
• GHC/Driver/Pipeline/Execute.hs +7/−5
• GHC/Driver/Session.hs +3/−0
• GHC/Hs/ImpExp.hs +0/−1
• GHC/HsToCore/Binds.hs +5/−5
• GHC/HsToCore/GuardedRHSs.hs +26/−18
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Prelude/Basic.hs +14/−0
• GHC/Rename/Bind.hs +29/−5
• GHC/Rename/Env.hs +27/−16
• GHC/Rename/Expr.hs +2/−2
• GHC/Rename/Names.hs +126/−25
• GHC/Settings/IO.hs +36/−28
• GHC/StgToByteCode.hs +13/−9
• GHC/SysTools/Ar.hs +1/−1
• GHC/SysTools/Process.hs +3/−1
• GHC/Tc/Errors/Ppr.hs +27/−23
• GHC/Tc/Errors/Types.hs +26/−4
• GHC/Tc/Gen/Arrow.hs +2/−1
• GHC/Tc/Gen/Expr.hs +1/−1
• GHC/Tc/Gen/Head.hs +1/−1
• GHC/Tc/Gen/Match.hs +58/−11
• GHC/Tc/Solver/Dict.hs +14/−10
• GHC/Tc/Solver/Monad.hs +85/−6
• GHC/Tc/Solver/Types.hs +1/−1
• GHC/Tc/TyCl.hs +2/−0
• GHC/Tc/Utils/Env.hs +9/−8
• GHC/Types/Id/Make.hs +69/−21
• ghc.cabal +4/−4

@@ -256,7 +256,7 @@         typeRepIdName,         mkTrTypeName,         mkTrConName,-        mkTrAppName,+        mkTrAppCheckedName,         mkTrFunName,         typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,         trGhcPrimModuleName,@@ -1376,7 +1376,7 @@   , someTypeRepDataConName   , mkTrTypeName   , mkTrConName-  , mkTrAppName+  , mkTrAppCheckedName   , mkTrFunName   , typeRepIdName   , typeNatTypeRepName@@ -1391,7 +1391,7 @@ typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey-mkTrAppName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey+mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey@@ -2508,7 +2508,7 @@ mkTyConKey   , mkTrTypeKey   , mkTrConKey-  , mkTrAppKey+  , mkTrAppCheckedKey   , mkTrFunKey   , typeNatTypeRepKey   , typeSymbolTypeRepKey@@ -2518,7 +2518,7 @@ mkTyConKey            = mkPreludeMiscIdUnique 503 mkTrTypeKey           = mkPreludeMiscIdUnique 504 mkTrConKey            = mkPreludeMiscIdUnique 505-mkTrAppKey            = mkPreludeMiscIdUnique 506+mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506 typeNatTypeRepKey     = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508 typeCharTypeRepKey    = mkPreludeMiscIdUnique 509

@@ -51,7 +51,6 @@  import Foreign hiding (shiftL, shiftR) import Data.Char        ( ord )-import Data.List        ( genericLength ) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map@@ -338,6 +337,7 @@   , lblEnv :: LabelEnvMap   } + inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) inspectAsm platform long_jumps initial_offset   = go (InspectState initial_offset 0 0 Map.empty)@@ -345,7 +345,7 @@     go s (NullAsm _) = (instrCount s, lblEnv s)     go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)       where n = ptrCount s-    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)+    go s (AllocLit ls k) = go (s { litCount = n + strictGenericLength ls }) (k n)       where n = litCount s     go s (AllocLabel lbl k) = go s' k       where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer (    CmmToken(..), cmmlex,   ) where@@ -680,7 +680,7 @@         -- match when checking the right context, just         -- the first match will do. #endif-{-# LINE 134 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 134 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -23,7 +23,7 @@ import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat    , getPicBaseMaybeNat, getPlatform, getConfig-   , getDebugBlock, getFileId+   , getDebugBlock, getFileId, getThisModuleNat    ) -- import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC@@ -835,21 +835,25 @@      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))+                                                 `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]     CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y       return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`-                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+                                                                         (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))+                                                 `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]     CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y       return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`-                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+                                                                         (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]       | w == W32 || w == W64@@ -1353,8 +1357,19 @@ -- Jumps  genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock-genJump expr@(CmmLit (CmmLabel lbl))-  = return $ unitOL (annExpr expr (J (TLabel lbl)))+genJump expr@(CmmLit (CmmLabel lbl)) = do+  cur_mod <- getThisModuleNat+  !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig+  let is_local = isLocalCLabel cur_mod lbl++  -- We prefer to generate a near jump using a simble `B` instruction+  -- with a range (+/-128MB). But if the target is outside the current module+  -- we might have to account for large code offsets. (#24648)+  if not useFarJumps || is_local+    then return $ unitOL (annExpr expr (J (TLabel lbl)))+    else do+      (target, _format, code) <- getSomeReg expr+      return (code `appOL` unitOL (annExpr expr (J (TReg target))))  genJump expr = do     (target, _format, code) <- getSomeReg expr

@@ -44,6 +44,7 @@    , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs    , ncgCmmStaticPred         :: !Bool            -- ^ Enable static control-flow prediction    , ncgEnableShortcutting    :: !Bool            -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+   , ncgEnableInterModuleFarJumps:: !Bool            -- ^ Use far-jumps for cross-module jumps.    , ncgComputeUnwinding      :: !Bool            -- ^ Compute block unwinding tables    , ncgEnableDeadCodeElimination :: !Bool        -- ^ Whether to enable the dead-code elimination    }

@@ -361,6 +361,7 @@   WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"   WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"   WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"+  WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt"   WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg"   WasmCond t -> do     asmTellLine "if"

@@ -1057,6 +1057,28 @@       x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" +-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.+lower_CMO_Un_Homo_Prim ::+  CLabel ->+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : pre)+      (t : pre)+  ) ->+  WasmTypeTag t ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do+  (ri, _) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  pure $+    WasmStatements $+      x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"+ -- | Lower a binary homogeneous 'CallishMachOp' to a ccall. lower_CMO_Bin_Homo ::   CLabel ->@@ -1160,8 +1182,8 @@ lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs@@ -1184,8 +1206,8 @@ lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =   lower_CMO_Un_Homo lbl "expm1f" rs xs-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop

@@ -305,6 +305,7 @@   WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)   WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)   WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)   WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)   WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre 

@@ -219,7 +219,7 @@                text ") both alive AND mapped to the same real register: " <> ppr real <>                text ". This isn't currently supported by the LLVM backend."          go (c:cs) f-            | fpr_num c == f = go cs f                    -- already covered by a real register+            | fpr_num c == f = go cs (f+1)                    -- already covered by a real register             | otherwise      = ctor f : go (c:cs) (f + 1) -- add padding register      fpr_ctor :: GlobalReg -> Int -> GlobalReg@@ -499,10 +499,10 @@   modifyEnv $ \env -> env { envAliases = emptyUniqSet }   return (concat defss, []) --- | Is a variable one of the special @$llvm@ globals?+-- | Is a variable one of the special @\@llvm@ globals? isBuiltinLlvmVar :: LlvmVar -> Bool isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =-    "$llvm" `isPrefixOf` unpackFS lbl+    "llvm." `isPrefixOf` unpackFS lbl isBuiltinLlvmVar _ = False  -- | Here we take a global variable definition, rename it with a

@@ -124,7 +124,7 @@             prio = LMStaticLit $ LMIntLit 0xffff i32         in LMStaticStrucU [prio, fn, null] entry_ty -    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+    arr_var = LMGlobalVar var_nm arr_ty Appending Nothing Nothing Global     mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing     entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]     arr_ty = LMArray (length clbls) entry_ty

@@ -20,7 +20,8 @@  module GHC.Core.Opt.SpecConstr(         specConstrProgram,-        SpecConstrAnnotation(..)+        SpecConstrAnnotation(..),+        SpecFailWarning(..)     ) where  import GHC.Prelude@@ -51,6 +52,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts +import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) )@@ -526,9 +528,11 @@         (see argToPat; #4448) (FS4) Only specialise on recursive types a finite number of times         (see sc_recursive; #5550; Note [Limit recursive specialisation])-(FS5) Lift the restriction on the maximum number of arguments which-        the optimisation will specialise.-        (see `too_many_worker_args` in `callsToNewPats`; #14003)+(FS5) Use a different restriction on the maximum number of arguments which+        the optimisation will specialise. We tried removing the limit on worker+        args for forced specs (#14003) but this caused issues when specializing+        code for large data structures (#25197).+        This is handled by `too_many_worker_args` in `callsToNewPats`  The flag holds only for specialising a single binding group, and NOT for nested bindings.  (So really it should be passed around explicitly@@ -782,16 +786,25 @@ specConstrProgram guts   = do { env0 <- initScEnv guts        ; us   <- getUniqueSupplyM-       ; let (_usg, binds') = initUs_ us $+       ; let (_usg, binds', warnings) = initUs_ us $                               scTopBinds env0 (mg_binds guts) +       ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)+        ; return (guts { mg_binds = binds' }) } -scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])-scTopBinds _env []     = return (nullUsage, [])-scTopBinds env  (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $+  where+    specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing+    warn_msg :: SpecFailWarnings -> SDoc+    warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$+                        text "which resulted in no specialization being generated for these functions:" $$+                        nest 2 (vcat (map ppr warnings)) $$+                        (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")+scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])+scTopBinds _env []     = return (nullUsage, [], [])+scTopBinds env  (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $                                                 (\env -> scTopBinds env bs)-                            ; return (usg, b' ++ bs') }+                            ; return (usg, b' ++ bs', warnings) }  {- ************************************************************************@@ -905,6 +918,12 @@   -- ^ The threshold at which a worker-wrapper transformation used as part of   -- this pass will no longer happen, measured in the number of arguments. +  , sc_max_forced_args  :: !Int+  -- ^ The threshold at which a worker-wrapper transformation used as part of+  -- this pass will no longer happen even if a SPEC arg was used to force+  -- specialization. Measured in the number of arguments.+  -- See Note [Forcing specialisation]+   , sc_debug     :: !Bool   -- ^ Whether to print debug information @@ -973,6 +992,7 @@ initScOpts :: DynFlags -> Module -> SpecConstrOpts initScOpts dflags this_mod = SpecConstrOpts         { sc_max_args    = maxWorkerArgs dflags,+          sc_max_forced_args = maxForcedSpecArgs dflags,           sc_debug       = hasPprDebug dflags,           sc_uf_opts     = unfoldingOpts dflags,           sc_module      = this_mod,@@ -1386,29 +1406,29 @@ -}  scBind :: TopLevelFlag -> ScEnv -> InBind-       -> (ScEnv -> UniqSM (ScUsage, a))   -- Specialise the scope of the binding-       -> UniqSM (ScUsage, [OutBind], a)+       -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))   -- Specialise the scope of the binding+       -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning]) scBind top_lvl env (NonRec bndr rhs) do_body   | isTyVar bndr         -- Type-lets may be created by doBeta-  = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)-       ; return (final_usage, [], body') }+  = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs)+       ; return (final_usage, [], body', warnings) }    | not (isTopLevel top_lvl)  -- Nested non-recursive value binding     -- See Note [Specialising local let bindings]   = do  { let (body_env, bndr') = extendBndr env bndr               -- Not necessary at top level; but here we are nested -        ; rhs_info  <- scRecRhs env (bndr',rhs)+        ; (rhs_info, rhs_ws)  <- scRecRhs env (bndr',rhs)          ; let body_env2 = extendHowBound body_env [bndr'] RecFun               rhs'      = ri_new_rhs rhs_info               body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') -        ; (body_usg, body') <- do_body body_env3+        ; (body_usg, body', warnings_body) <- do_body body_env3            -- Now make specialised copies of the binding,           -- based on calls in body_usg-        ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info+        ; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info           -- NB: For non-recursive bindings we inherit sc_force flag from           -- the parent function (see Note [Forcing specialisation]) @@ -1417,7 +1437,7 @@               bind_usage = (body_usg `delCallsFor` [bndr'])                            `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg] -        ; return (bind_usage, spec_bnds, body')+        ; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws])         }    | otherwise  -- Top-level, non-recursive value binding@@ -1429,15 +1449,15 @@     --     -- I tried always specialising non-recursive top-level bindings too,     -- but found some regressions (see !8135).  So I backed off.-  = do { (rhs_usage, rhs')   <- scExpr env rhs+  = do { (rhs_usage, rhs', ws_rhs)   <- scExpr env rhs         -- At top level, we've already put all binders into scope; see initScEnv        -- Hence no need to call `extendBndr`. But we still want to        -- extend the `ValueEnv` to record the value of this binder.        ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')-       ; (body_usage, body') <- do_body body_env+       ; (body_usage, body', body_warnings) <- do_body body_env -       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }+       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) }  scBind top_lvl env (Rec prs) do_body   | isTopLevel top_lvl@@ -1448,19 +1468,20 @@     -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor     --       why it only applies at top level. But that's the way it has been     --       for a while. See #21456.-    do  { (body_usg, body') <- do_body rhs_env2-        ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss+    do  { (body_usg, body', warnings_body) <- do_body rhs_env2+        ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss         ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)                         `delCallsFor` bndrs'               bind'   = Rec (bndrs' `zip` rhss')-        ; return (all_usg, [bind'], body') }+        ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) }    | otherwise-  = do  { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)-        ; (body_usg, body') <- do_body rhs_env2+  = do  { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; let rhs_ws = mconcat rhs_wss+        ; (body_usg, body', warnings_body) <- do_body rhs_env2 -        ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)-                                       (scu_calls body_usg) rhs_infos+        ; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec)+                                          (scu_calls body_usg) rhs_infos                 -- Do not unconditionally generate specialisations from rhs_usgs                 -- Instead use them only if we find an unspecialised call                 -- See Note [Seeding recursive groups]@@ -1471,7 +1492,7 @@                         -- zipWithEqual: length of returned [SpecInfo]                         -- should be the same as incoming [RhsInfo] -        ; return (all_usg, [bind'], body') }+        ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) }   where     (bndrs,rhss) = unzip prs     force_spec   = any (forceSpecBndr env) bndrs    -- Note [Forcing specialisation]@@ -1499,59 +1520,63 @@ harmful.  I'm not sure. -} +withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings)+withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2)+ -------------------------scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)         -- The unique supply is needed when we invent         -- a new name for the specialised function and its args  scExpr env e = scExpr' env e  scExpr' env (Var v)      = case scSubstId env v of-                            Var v' -> return (mkVarUsage env v' [], Var v')+                            Var v' -> return (mkVarUsage env v' [], Var v', [])                             e'     -> scExpr (zapScSubst env) e'  scExpr' env (Type t)     =   let !(MkSolo ty') = scSubstTy env t-  in return (nullUsage, Type ty')-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-                              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))+  in return (nullUsage, Type ty', [])+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c), [])+scExpr' _   e@(Lit {})   = return (nullUsage, e, [])+scExpr' env (Tick t e)   = do (usg, e', ws) <- scExpr env e+                              return (usg, Tick (scTickish env t) e', ws)+scExpr' env (Cast e co)  = do (usg, e', ws) <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co), ws)                               -- Important to use mkCast here                               -- See Note [SpecConstr call patterns] scExpr' env e@(App _ _)  = scApp env (collectArgs e) scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b-                              (usg, e') <- scExpr env' e-                              return (usg, Lam b' e')+                              (usg, e', ws) <- scExpr env' e+                              return (usg, Lam b' e', ws)  scExpr' env (Let bind body)-  = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $+  = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $                                          (\env -> scExpr env body)-       ; return (final_usage, mkLets binds' body') }+       ; return (final_usage, mkLets binds' body', ws) }  scExpr' env (Case scrut b ty alts)-  = do  { (scrut_usg, scrut') <- scExpr env scrut+  = do  { (scrut_usg, scrut', ws) <- scExpr env scrut         ; case isValue (sc_vals env) scrut' of                 Just (ConVal args_are_work_free con args)-                   | args_are_work_free -> sc_con_app con args scrut'+                   | args_are_work_free -> sc_con_app con args scrut' ws                      -- Don't duplicate work!!  #7865                      -- See Note [ConVal work-free-ness] (1)-                _other -> sc_vanilla scrut_usg scrut'+                _other -> sc_vanilla scrut_usg scrut' ws         }   where-    sc_con_app con args scrut'  -- Known constructor; simplify+    sc_con_app con args scrut' ws  -- Known constructor; simplify      = do { let Alt _ bs rhs = findAlt con alts                                   `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")                 alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)-          ; scExpr alt_env' rhs }+          ; (use',expr',ws_new) <- scExpr alt_env' rhs+          ; return (use',expr',ws ++ ws_new) } -    sc_vanilla scrut_usg scrut' -- Normal case+    sc_vanilla scrut_usg scrut' ws -- Normal case      = do { let (alt_env,b') = extendBndrWith RecArg env b                         -- Record RecArg for the components -          ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts+          ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (sc_alt alt_env scrut' b') alts            ; let scrut_occ  = foldr combineOcc NoOcc alt_occs                 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ@@ -1561,21 +1586,21 @@           ; let !(MkSolo ty') = scSubstTy env ty            ; return (foldr combineUsage scrut_usg' alt_usgs,-                    Case scrut' b' ty'  alts') }+                    Case scrut' b' ty'  alts', ws ++ concat ws_alts) }      single_alt = isSingleton alts      sc_alt env scrut' b' (Alt con bs rhs)      = do { let (env1, bs1) = extendBndrsWith RecArg env bs                 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1-          ; (usg, rhs') <- scExpr env2 rhs+          ; (usg, rhs', ws) <- scExpr env2 rhs           ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)                 scrut_occ = case con of                                DataAlt dc -- See Note [Do not specialise evals]                                   | not (single_alt && all deadArgOcc arg_occs)                                   -> ScrutOcc (unitUFM dc arg_occs)                                _  -> UnkOcc-          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }+          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) }   -- | Substitute the free variables captured by a breakpoint.@@ -1624,19 +1649,20 @@   still worth specialising on x. Hence the /single-alternative/ guard. -} -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)+scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)  scApp env (Var fn, args)        -- Function is a variable   = assert (not (null args)) $     do  { args_w_usgs <- mapM (scExpr env) args-        ; let (arg_usgs, args') = unzip args_w_usgs+        ; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs               arg_usg = combineUsages arg_usgs+              arg_w = concat arg_ws         ; case scSubstId env fn of-            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')+            fn'@(Lam {}) -> withWarnings arg_w <$> scExpr (zapScSubst env) (doBeta fn' args')                         -- Do beta-reduction and try again              Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args',-                               mkApps (Var fn') args')+                               mkApps (Var fn') args', arg_w )                where                  -- arg_usg': see Note [Specialising on dictionaries]                  arg_usg' | Just cls <- isClassOpId_maybe fn'@@ -1645,7 +1671,7 @@                           | otherwise                           = arg_usg -            other_fn' -> return (arg_usg, mkApps other_fn' args') }+            other_fn' -> return (arg_usg, mkApps other_fn' args', arg_w) }                 -- NB: doing this ignores any usage info from the substituted                 --     function, but I don't think that matters.  If it does                 --     we can fix it.@@ -1659,9 +1685,9 @@ -- which it may, we can get --      (let f = ...f... in f) arg1 arg2 scApp env (other_fn, args)-  = do  { (fn_usg,   fn')   <- scExpr env other_fn-        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args-        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }+  = do  { (fn_usg,   fn', fn_ws)   <- scExpr env other_fn+        ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) }  ---------------------- mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage@@ -1677,16 +1703,16 @@             | otherwise = evalScrutOcc  -----------------------scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings) scRecRhs env (bndr,rhs)   = do  { let (arg_bndrs,body)       = collectBinders rhs               (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs-        ; (body_usg, body')         <- scExpr body_env body+        ; (body_usg, body', body_ws)         <- scExpr body_env body         ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'         ; return (RI { ri_rhs_usg = rhs_usg                      , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'                      , ri_lam_bndrs = arg_bndrs, ri_lam_body = body-                     , ri_arg_occs = arg_occs }) }+                     , ri_arg_occs = arg_occs }, body_ws) }                 -- The arg_occs says how the visible,                 -- lambda-bound binders of the RHS are used                 -- (including the TyVar binders)@@ -1755,7 +1781,7 @@ specNonRec :: ScEnv            -> CallEnv         -- Calls in body            -> RhsInfo         -- Structure info usage info for un-specialised RHS-           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)+           -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])       -- Usage from RHSs (specialised and not)                                                --     plus details of specialisations  specNonRec env body_calls rhs_info@@ -1765,11 +1791,12 @@ specRec :: ScEnv         -> CallEnv                         -- Calls in body         -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs-        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)+        -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+                                           -- Usage from all RHSs (specialised and not)                                            --     plus details of specialisations  specRec env body_calls rhs_infos-  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)+  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) []     -- body_calls: see Note [Seeding recursive groups]     -- NB: 'go' always calls 'specialise' once, which in turn unleashes     --     si_mb_unspec if there are any boring calls in body_calls,@@ -1784,23 +1811,25 @@                               -- Two accumulating parameters:                  -> ScUsage      -- Usage from earlier specialisations                  -> [SpecInfo]   -- Details of specialisations so far-                 -> UniqSM (ScUsage, [SpecInfo])-    go n_iter seed_calls usg_so_far spec_infos+                 -> SpecFailWarnings -- Warnings so far+                 -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+    go n_iter seed_calls usg_so_far spec_infos ws_so_far       = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)         --                           , text "iteration" <+> int n_iter         --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)         --                    ]) $         do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos-            ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg++            ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg                   extra_usg = combineUsages extra_usg_s                   all_usg   = usg_so_far `combineUsage` extra_usg                   new_calls = scu_calls extra_usg-            ; go_again n_iter new_calls all_usg all_spec_infos }+            ; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) }      -- go_again deals with termination-    go_again n_iter seed_calls usg_so_far spec_infos+    go_again n_iter seed_calls usg_so_far spec_infos ws_so_far       | isEmptyVarEnv seed_calls-      = return (usg_so_far, spec_infos)+      = return (usg_so_far, spec_infos, ws_so_far)        -- Limit recursive specialisation       -- See Note [Limit recursive specialisation]@@ -1814,10 +1843,10 @@         -- for the unspecialised function, since it may now be called         -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $         let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)-        in return (usg_so_far `combineUsage` rhs_usgs, spec_infos)+        in return (usg_so_far `combineUsage` rhs_usgs, spec_infos, ws_so_far)        | otherwise-      = go (n_iter + 1) seed_calls usg_so_far spec_infos+      = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far      -- See Note [Limit recursive specialisation]     the_limit = case sc_count opts of@@ -1830,7 +1859,7 @@    -> CallEnv                     -- Info on newly-discovered calls to this function    -> RhsInfo    -> SpecInfo                    -- Original RHS plus patterns dealt with-   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage+   -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])  -- New specialised versions and their usage  -- See Note [spec_usg includes rhs_usg] @@ -1848,7 +1877,7 @@   | isDeadEndId fn  -- Note [Do not specialise diverging functions]                     -- /and/ do not generate specialisation seeds from its RHS   = -- pprTrace "specialise bot" (ppr fn) $-    return (nullUsage, spec_info)+    return (nullUsage, spec_info, [])    | not (isNeverActive (idInlineActivation fn))       -- See Note [Transfer activation]@@ -1859,7 +1888,7 @@   , not (null arg_bndrs)                         -- Only specialise functions   , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it   = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $-    do  { (boring_call, pats_discarded, new_pats)+    do  { (boring_call, pats_discarded, new_pats, warnings)              <- callsToNewPats env fn spec_info arg_occs all_calls          ; let n_pats = length new_pats@@ -1874,7 +1903,7 @@ --                                       , text "new_pats" <+> ppr new_pats])          ; let spec_env = decreaseSpecCount env n_pats-        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)+        ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body)                                                  (new_pats `zip` [spec_count..])                 -- See Note [Specialise original body] @@ -1898,15 +1927,16 @@          ; return (new_usg, SI { si_specs     = new_specs ++ specs                               , si_n_specs   = spec_count + n_pats-                              , si_mb_unspec = mb_unspec' }) }+                              , si_mb_unspec = mb_unspec' }+                 ,warnings ++ concat new_wss) }    | otherwise  -- No calls, inactive, or not a function                -- Behave as if there was a single, boring call   = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $     case mb_unspec of    -- Behave as if there was a single, boring call-      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }, [])                          -- See Note [spec_usg includes rhs_usg]-      Nothing      -> return (nullUsage, spec_info)+      Nothing      -> return (nullUsage, spec_info, [])   ---------------------@@ -1915,7 +1945,7 @@          -> [InVar]     -- Lambda-binders of RHS; should match patterns          -> InExpr      -- Body of the original function          -> (CallPat, Int)-         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding+         -> UniqSM (ScUsage, OneSpec, SpecFailWarnings)   -- Rule and binding, warnings if any  -- spec_one creates a specialised copy of the function, together -- with a rule for using it.  I'm very proud of how short this@@ -1967,7 +1997,7 @@          -- Specialise the body         -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)-        ; (spec_usg, spec_body) <- scExpr body_env body+        ; (spec_usg, spec_body, body_warnings) <- scExpr body_env body                  -- And build the results         ; (qvars', pats') <- generaliseDictPats qvars pats@@ -2016,7 +2046,7 @@ --               ]         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule                                , os_id = spec_id-                               , os_rhs = spec_rhs }) }+                               , os_rhs = spec_rhs }, body_warnings) }  generaliseDictPats :: [Var] -> [CoreExpr]  -- Quantified vars and pats                    -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats@@ -2400,12 +2430,26 @@                                , text "cp_args =" <+> ppr args                                , text "cp_strict_args = " <> ppr strict ]) +newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name }++type SpecFailWarnings = [SpecFailWarning]++instance Outputable SpecFailWarning where+  ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name++combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings+combineSpecWarning = (++)++data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name+ callsToNewPats :: ScEnv -> Id                -> SpecInfo                -> [ArgOcc] -> [Call]                -> UniqSM ( Bool        -- At least one boring call                          , Bool        -- Patterns were discarded-                         , [CallPat] ) -- Patterns to specialise+                         , [CallPat]   -- Patterns to specialise+                         , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about)+                         ) -- Result has no duplicate patterns, -- nor ones mentioned in si_specs (hence "new" patterns) -- Bool indicates that there was at least one boring pattern@@ -2431,12 +2475,18 @@               non_dups = subsumePats in_scope new_pats                -- Remove ones that have too many worker variables-              small_pats = filterOut too_many_worker_args non_dups+              (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups -              too_many_worker_args _-                | sc_force env = False -- See (FS5) of Note [Forcing specialisation]+              -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool               too_many_worker_args (CP { cp_qvars = vars, cp_args = args })-                = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+                | sc_force env+                -- See (FS5) of Note [Forcing specialisation]+                = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars)+                    then WorkerSmallEnough+                    else WorkerTooLargeForced (idName fn)+                | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+                = WorkerSmallEnough+                | otherwise = WorkerTooLarge                   -- We are about to construct w/w pair in 'spec_one'.                   -- Omit specialisation leading to high arity workers.                   -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils@@ -2452,10 +2502,21 @@ --                                        , text "done_specs:" <+> ppr (map os_pat done_specs) --                                        , text "trimmed_pats:" <+> ppr trimmed_pats ]) -        ; return (have_boring_call, pats_were_discarded, trimmed_pats) }+        ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) }           -- If any of the calls does not give rise to a specialisation, either           -- because it is boring, or because there are too many specialisations,           -- return a flag to say so, so that we know to keep the original function.+  where+    partitionByWorkerSize worker_size pats = go pats [] []+      where+        go [] small warnings = (small, warnings)+        go (p:ps) small warnings+          | WorkerSmallEnough <- worker_size p+          = go ps (p:small) warnings+          | WorkerTooLarge <- worker_size p+          = go ps small warnings+          | WorkerTooLargeForced name <- worker_size p+          = go ps small (SpecFailForcedArgCount name : warnings)   trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])

@@ -27,7 +27,7 @@   -- Implicit parameters   isIPLikePred, mentionsIP, isIPTyCon, isIPClass,   isCallStackTy, isCallStackPred, isCallStackPredTy,-  isExceptionContextPred,+  isExceptionContextPred, isExceptionContextTy,   isIPPred_maybe,    -- Evidence variables@@ -39,7 +39,6 @@  import GHC.Core.Type import GHC.Core.Class-import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Types.Var@@ -292,7 +291,7 @@   | otherwise   = Nothing --- | Is a type a 'CallStack'?+-- | Is a type an 'ExceptionContext'? isExceptionContextTy :: Type -> Bool isExceptionContextTy ty   | Just tc <- tyConAppTyCon_maybe ty@@ -338,31 +337,38 @@ isIPLikePred :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters]-isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred+isIPLikePred pred =+  mentions_ip_pred initIPRecTc (const True) (const True) pred -mentionsIP :: Type -> Class -> [Type] -> Bool--- Is (cls tys) an implicit parameter with key `str_ty`, or--- is any of its superclasses such at thing.+mentionsIP :: (Type -> Bool) -- ^ predicate on the string+           -> (Type -> Bool) -- ^ predicate on the type+           -> Class+           -> [Type] -> Bool+-- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:+--+--    - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@+--      are both @True@,+--    - or any superclass of @cls tys@ has this property.+-- -- See Note [Local implicit parameters]-mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys+mentionsIP = mentions_ip initIPRecTc -mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool-mentions_ip rec_clss mb_str_ty cls tys-  | Just (str_ty', _) <- isIPPred_maybe cls tys-  = case mb_str_ty of-       Nothing -> True-       Just str_ty -> str_ty `eqType` str_ty'+mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool+mentions_ip rec_clss str_cond ty_cond cls tys+  | Just (str_ty, ty) <- isIPPred_maybe cls tys+  = str_cond str_ty && ty_cond ty   | otherwise-  = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)+  = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)        | sc_sel_id <- classSCSelIds cls ] -mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool-mentions_ip_pred  rec_clss mb_str_ty ty++mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool+mentions_ip_pred rec_clss str_cond ty_cond ty   | Just (cls, tys) <- getClassPredTys_maybe ty   , let tc = classTyCon cls   , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss                       else checkRecTc rec_clss tc-  = mentions_ip rec_clss' mb_str_ty cls tys+  = mentions_ip rec_clss' str_cond ty_cond cls tys   | otherwise   = False -- Includes things like (D []) where D is           -- a Constraint-ranged family; #7785@@ -429,7 +435,38 @@ * The superclass hunt stops when it encounters the same class again,   but in principle we could have the same class, differently instantiated,   and the second time it could have an implicit parameter-I'm going to treat these as problems for another day. They are all exotic.  -}+I'm going to treat these as problems for another day. They are all exotic.++Note [Using typesAreApart when calling mentionsIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call 'mentionsIP' in two situations:++  (1) to check that a predicate does not contain any implicit parameters+      IP str ty, for a fixed literal str and any type ty,+  (2) to check that a predicate does not contain any HasCallStack or+      HasExceptionContext constraints.++In both of these cases, we want to be sure, so we should be conservative:++  For (1), the predicate might contain an implicit parameter IP Str a, where+  Str is a type family such as:++    type family MyStr where MyStr = "abc"++  To safeguard against this (niche) situation, instead of doing a simple+  type equality check, we use 'typesAreApart'. This allows us to recognise+  that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.++  For (2), we similarly might have++    type family MyCallStack where MyCallStack = CallStack++  Again, here we use 'typesAreApart'. This allows us to see that++    (?foo :: MyCallStack)++  is indeed a CallStack constraint, hidden under a type family.+-}  {- ********************************************************************* *                                                                      *

@@ -2659,6 +2659,7 @@ tyConStupidTheta tc@(TyCon { tyConDetails = details })   | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid   | PrimTyCon {} <- details                         = []+  | PromotedDataCon {} <- details                   = []   | otherwise = pprPanic "tyConStupidTheta" (ppr tc)  -- | Extract the 'TyVar's bound by a vanilla type synonym

@@ -68,6 +68,7 @@    , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags    , ncgCmmStaticPred       = gopt Opt_CmmStaticPred dflags    , ncgEnableShortcutting  = gopt Opt_AsmShortcutting dflags+   , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps dflags    , ncgComputeUnwinding    = debugLevel dflags > 0    , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags)                                      -- Disable when -finfo-table-map is on (#20428)

@@ -395,6 +395,7 @@   unfoldingOpts         :: !UnfoldingOpts,    maxWorkerArgs         :: Int,+  maxForcedSpecArgs     :: Int,    ghciHistSize          :: Int, @@ -676,6 +677,8 @@          unfoldingOpts = defaultUnfoldingOpts,         maxWorkerArgs = 10,+        maxForcedSpecArgs = 333,+        -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5          ghciHistSize = 50, -- keep a log of length 50 by default @@ -1203,7 +1206,6 @@     ++ default_PIC platform      ++ validHoleFitDefaults-      where platform = sTargetPlatform settings 

@@ -299,6 +299,7 @@    | Opt_CmmElimCommonBlocks    | Opt_CmmControlFlow    | Opt_AsmShortcutting+   | Opt_InterModuleFarJumps    | Opt_OmitYields    | Opt_FunToThunk               -- deprecated    | Opt_DictsStrict                     -- be strict in argument dictionaries@@ -544,6 +545,7 @@    , Opt_CmmSink    , Opt_CmmElimCommonBlocks    , Opt_AsmShortcutting+   , Opt_InterModuleFarJumps    , Opt_FunToThunk    , Opt_DmdTxDictSel    , Opt_Loopification

@@ -400,7 +400,7 @@   let dflags    = hsc_dflags hsc_env   let logger    = hsc_logger hsc_env   let unit_env  = hsc_unit_env hsc_env-  let home_unit = hsc_home_unit hsc_env+  let home_unit = hsc_home_unit_maybe hsc_env   let tmpfs     = hsc_tmpfs hsc_env   let platform  = ue_platform unit_env   let hcc       = cc_phase `eqPhase` HCc@@ -492,10 +492,12 @@           -- These symbols are imported into the stub.c file via RtsAPI.h, and the           -- way we do the import depends on whether we're currently compiling           -- the base package or not.-                 ++ (if platformOS platform == OSMinGW32 &&-                        isHomeUnitId home_unit baseUnitId-                          then [ "-DCOMPILING_BASE_PACKAGE" ]-                          else [])+                 ++ (case home_unit of+                        Just hu+                          | isHomeUnitId hu baseUnitId+                          , platformOS platform == OSMinGW32+                          -> ["-DCOMPILING_BASE_PACKAGE"]+                        _ -> [])                   -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.                  ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)

@@ -1813,6 +1813,8 @@    , make_ord_flag defFlag "fmax-worker-args"       (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defFlag "fmax-forced-spec-args"+      (intSuffix (\n d -> d {maxForcedSpecArgs = n}))   , make_ord_flag defGhciFlag "fghci-hist-size"       (intSuffix (\n d -> d {ghciHistSize = n}))   , make_ord_flag defGhcFlag "fmax-inline-alloc-size"@@ -2452,6 +2454,7 @@   flagSpec "gen-manifest"                     Opt_GenManifest,   flagSpec "ghci-history"                     Opt_GhciHistory,   flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "inter-module-far-jumps"               Opt_InterModuleFarJumps,   flagSpec "validate-ide-info"                Opt_ValidateHie,   flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,   flagGhciSpec "no-it"                        Opt_NoIt,

@@ -257,7 +257,6 @@ ieNames (IEThingAbs  _ (L _ n) _)      = [ieWrappedName n] ieNames (IEThingAll  _ (L _ n) _)      = [ieWrappedName n] ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns--- NB the above case does not include names of field selectors ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = []

@@ -1533,14 +1533,14 @@   | Just (t1,t2) <- splitAppTy_maybe ty   = do { e1  <- getRep ev1 t1        ; e2  <- getRep ev2 t2-       ; mkTrApp <- dsLookupGlobalId mkTrAppName-                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-                    --            TypeRep a -> TypeRep b -> TypeRep (a b)+       ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName+                    -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+                    --                   TypeRep a -> TypeRep b -> TypeRep (a b)        ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,                                                      -- since it's a kind-       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])+       ; let expr =  mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ])                             [ e1, e2 ]-       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr+       -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr        ; return expr        } 

@@ -78,7 +78,8 @@ dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)        -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))-  = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty+  = updPmNablas rhs_nablas $+      matchGuards (map unLoc guards) hs_ctx rhs rhs_ty  {- ************************************************************************@@ -90,7 +91,6 @@  matchGuards :: [GuardStmt GhcTc]     -- Guard             -> HsMatchContextRn      -- Context-            -> Nablas                -- The RHS's covered set for PmCheck             -> LHsExpr GhcTc         -- RHS             -> Type                  -- Type of RHS of guard             -> DsM (MatchResult CoreExpr)@@ -98,8 +98,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ nablas rhs _-  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)+matchGuards [] _ rhs _+  = do  { core_rhs <- dsLExpr rhs         ; return (cantFailMatchResult core_rhs) }          -- BodyStmts must be guards@@ -109,42 +109,50 @@         -- NB:  The success of this clause depends on the typechecker not         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors         --      If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty   | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+    match_result <- matchGuards stmts ctx rhs rhs_ty     return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty     pred_expr <- dsLExpr expr     return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty-    return (adjustMatchResultDs (dsLocalBinds binds) match_result)+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do+    ldi_nablas <- getPmNablas+    match_result <- matchGuards stmts ctx rhs rhs_ty+      -- Propagate long-distance information when desugaring let bindings, e.g.+      --+      --  f r@(K1 {})+      --    | let g = fld r+      --    = g+      --+      -- Failing to do so resulted in #25749.+    return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result)         -- NB the dsLet occurs inside the match_result         -- Reason: dsLet takes the body expression as its argument         --         so we can't desugar the bindings without the         --         body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do     let upat = unLoc pat     match_var <- selectMatchVar ManyTy upat        -- We only allow unrestricted patterns in guards, hence the `Many`        -- above. It isn't clear what linear patterns would mean, maybe we will        -- figure it out in the future. -    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+    match_result <- matchGuards stmts ctx rhs rhs_ty     core_rhs <- dsLExpr bind_rhs     match_result' <-       matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx)       pat rhs_ty match_result     return $ bindNonRec match_var core_rhs <$> match_result' -matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ _ =+matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"+matchGuards (ApplicativeStmt {} : _) _ _ _ =   panic "matchGuards ApplicativeLastStmt"  {-

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Parser/HaddockLex.x" #-} {-# OPTIONS_GHC -funbox-strict-fields #-}  module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where@@ -352,7 +352,7 @@         -- match when checking the right context, just         -- the first match will do. #endif-{-# LINE 84 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 84 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput   { alexInput_position     :: !RealSrcLoc   , alexInput_string       :: !ByteString

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -1215,7 +1215,7 @@         -- match when checking the right context, just         -- the first match will do. #endif-{-# LINE 793 "_build/source-dist/ghc-9.10.2-src/ghc-9.10.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 793 "_build/source-dist/ghc-9.10.3-src/ghc-9.10.3/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs   = OpWsPrefix         -- a !b

@@ -23,6 +23,8 @@   ,module Bits   ,shiftL, shiftR   ,head, tail++  , strictGenericLength   ) where  @@ -126,3 +128,15 @@ tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-}++{- |+The 'genericLength' function defined in base can't be specialised due to the+NOINLINE pragma.++It is also not strict in the accumulator, and strictGenericLength is not exported.++See #25706 for why it is important to use a strict, specialised version.++-}+strictGenericLength :: Num a => [x] -> a+strictGenericLength = fromIntegral . length

@@ -1303,14 +1303,38 @@              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })          -- see Note [Empty MatchGroups]-  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt))+  = do { when (null ms) $ checkEmptyCase ctxt        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }++-- Check the validity of a MatchGroup with an empty list of alternatives.+--+--  1. Normal `case x of {}` passes this check as long as EmptyCase is enabled.+--     Ditto lambda-case `\case {}`.+--+--  2. Multi-case with no alternatives `\cases {}` is never valid.+--+--  3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not+--     considered here because there is no syntax to construct them with+--     no alternatives.+--+-- Test case: rename/should_fail/RnEmptyCaseFail+--+-- Validation continues in the type checker, namely in tcMatches.+-- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match+checkEmptyCase :: HsMatchContextRn -> RnM ()+checkEmptyCase ctxt+  | disallowed_ctxt =+      addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt)+  | otherwise =+      unlessXOptM LangExt.EmptyCase $+        addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag)   where-    mustn't_be_empty = case ctxt of-      LamAlt LamCases -> return True-      ArrowMatchCtxt (ArrowLamAlt LamCases) -> return True-      _ -> not <$> xoptM LangExt.EmptyCase+    disallowed_ctxt =+      case ctxt of+        LamAlt LamCases -> True+        ArrowMatchCtxt (ArrowLamAlt LamCases) -> True+        _ -> False  rnMatch :: AnnoBody body         => HsMatchContextRn

@@ -436,6 +436,7 @@        ; case info of             IAmConLike con_info -> return con_info             UnboundGRE          -> return ConHasPositionalArgs+            IAmTyCon {}         -> failIllegalTyCon WL_Constructor con_name             _ -> pprPanic "lookupConstructorInfo: not a ConLike" $                       vcat [ text "name:" <+> ppr con_name ]        }@@ -1029,24 +1030,12 @@ lookupOccRn :: RdrName -> RnM Name lookupOccRn = lookupOccRn' WL_Anything --- lookupOccRnConstr looks up an occurrence of a RdrName and displays--- constructors and pattern synonyms as suggestions if it is not in scope------ There is a fallback to the type level, when the first lookup fails.--- This is required to implement a pat-to-type transformation--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)--- Consider this example:------   data VisProxy a where VP :: forall a -> VisProxy a------   f :: VisProxy Int -> ()---   f (VP Int) = ()+-- | Look up an occurrence of a 'RdrName'. ----- Here `Int` is actually a type, but it stays on position where--- we expect a data constructor.+-- Displays constructors and pattern synonyms as suggestions if+-- it is not in scope. ----- In all other cases we just use this additional lookup for better--- error messaging (See Note [Promotion]).+-- See Note [lookupOccRnConstr] lookupOccRnConstr :: RdrName -> RnM Name lookupOccRnConstr rdr_name   = do { mb_gre <- lookupOccRn_maybe rdr_name@@ -1057,6 +1046,28 @@             ; case mb_ty_gre of               Just gre -> return $ greName gre               Nothing ->  reportUnboundName' WL_Constructor rdr_name} }++{- Note [lookupOccRnConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.++However, there is a fallback to the type level when the lookup fails.+This is required to implement a pat-to-type transformation+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)++Consider this example:++  data VisProxy a where VP :: forall a -> VisProxy a++  f :: VisProxy Int -> ()+  f (VP Int) = ()++Here `Int` is actually a type, but it occurs in a position in which we expect+a data constructor.++In all other cases we just use this additional lookup for better+error messaging (See Note [Promotion]).+-}  -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- record fields as suggestions if it is not in scope

@@ -532,9 +532,9 @@   = do { (expr', fvs) <- rnLExpr expr        ; return (ExplicitSum noExtField alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con = con_id+rnExpr (RecordCon { rcon_con = con_rdr                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }

@@ -92,6 +92,7 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps ( removeDups ) +import Control.Arrow    ( second ) import Control.Monad import Data.Foldable    ( for_ ) import Data.IntMap      ( IntMap )@@ -99,6 +100,8 @@ import Data.Map         ( Map ) import qualified Data.Map as Map import Data.Ord         ( comparing )+import Data.Semigroup   ( Any(..) )+import qualified Data.Semigroup as S import Data.List        ( partition, find, sortBy ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -1873,21 +1876,21 @@                                -- srcSpanEnd: see Note [The ImportMap]                     `orElse` [] -        used_names   = mkNameSet (map      greName        used_gres)+        used_gre_env = mkGlobalRdrEnv used_gres         used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)          unused_imps   -- Not trivial; see eg #7454           = case imps of               Just (Exactly, L _ imp_ies) ->-                                 foldr (add_unused . unLoc) emptyNameSet imp_ies+                let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies+                in  collectUnusedNames unused               _other -> emptyNameSet -- No explicit import list => no unused-name list -        add_unused :: IE GhcRn -> NameSet -> NameSet-        add_unused (IEVar _ n _)    acc   = add_unused_name (lieWrappedName n) acc-        add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) acc+        add_unused :: IE GhcRn -> UnusedNames -> UnusedNames+        add_unused (IEVar _ n _)      acc = add_unused_name (lieWrappedName n) True acc+        add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) False acc         add_unused (IEThingAll _ n _) acc = add_unused_all  (lieWrappedName n) acc-        add_unused (IEThingWith _ p wc ns _) acc =-          add_wc_all (add_unused_with pn xs acc)+        add_unused (IEThingWith _ p wc ns _) acc = add_wc_all (add_unused_with pn xs acc)           where pn = lieWrappedName p                 xs = map lieWrappedName ns                 add_wc_all = case wc of@@ -1895,23 +1898,117 @@                             IEWildcard _ -> add_unused_all pn         add_unused _ acc = acc -        add_unused_name n acc-          | n `elemNameSet` used_names = acc-          | otherwise                  = acc `extendNameSet` n-        add_unused_all n acc-          | n `elemNameSet` used_names   = acc-          | n `elemNameSet` used_parents = acc-          | otherwise                    = acc `extendNameSet` n+        add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames+        add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs)+          | is_ie_var+          , isFieldName n+          -- See Note [Reporting unused imported duplicate record fields]+          = let+              fs = getOccFS n+              (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False)+              acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used)+            in UnusedNames acc_ns acc_fs'+          | used+          = acc+          | otherwise+          = UnusedNames (acc_ns `extendNameSet` n) acc_fs+          where+            used = isJust $ lookupGRE_Name used_gre_env n++        add_unused_all :: Name -> UnusedNames -> UnusedNames+        add_unused_all n (UnusedNames acc_ns acc_fs)+          | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs+          | n `elemNameSet` used_parents             = UnusedNames acc_ns acc_fs+          | otherwise                                = UnusedNames (acc_ns `extendNameSet` n) acc_fs++        add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames         add_unused_with p ns acc-          | all (`elemNameSet` acc1) ns = add_unused_name p acc1-          | otherwise = acc1+          | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1+          | otherwise                      = acc1           where-            acc1 = foldr add_unused_name acc ns-       -- If you use 'signum' from Num, then the user may well have-       -- imported Num(signum).  We don't want to complain that-       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.+            acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns+        -- If you use 'signum' from Num, then the user may well have+        -- imported Num(signum).  We don't want to complain that+        -- Num is not itself mentioned.  Hence the two cases in add_unused_with.  +-- | An accumulator for unused names in an import list.+--+-- See Note [Reporting unused imported duplicate record fields].+data UnusedNames =+  UnusedNames+    { unused_names :: NameSet+       -- ^ Unused 'Name's in an import list, not including record fields+       -- that are plain 'IEVar' imports+    , rec_fld_uses :: FastStringEnv (NameSet, Any)+      -- ^ Record fields imported without a parent (i.e. an 'IEVar' import).+      --+      -- The 'Any' value records whether any of the record fields+      -- sharing the same underlying 'FastString' have been used.+    }+instance Outputable UnusedNames where+  ppr (UnusedNames nms flds) =+    text "UnusedNames" <+>+      braces (ppr nms <+> ppr (fmap (second getAny) flds))++-- | Collect all unused names from a 'UnusedNames' value.+collectUnusedNames :: UnusedNames -> NameSet+collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds })+  = nms S.<> unused_flds+  where+    unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds+    collect_unused :: (NameSet, Any) -> NameSet -> NameSet+    collect_unused (nms, Any at_least_one_name_is_used) acc+      | at_least_one_name_is_used = acc+      | otherwise                 = unionNameSet nms acc++{- Note [Reporting unused imported duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#24035):++  {-# LANGUAGE DuplicateRecordFields #-}+  module M1 (R1(..), R2(..)) where+    data R1 = MkR1 { fld :: Int }+    data R2 = MkR2 { fld :: Int }++  {-# LANGUAGE DuplicateRecordFields #-}+  module M2 where+    import M1 (R1(MkR1), R2, fld)+    f :: R1 -> Int+    f (MkR1 { fld = x }) = x+    g :: R2 -> Int+    g _ = 3++In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs,+namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular+the 'findImportUsage' function, it's as if the user had imported the two names+separately (even though no source syntax allows that).++This means that we need to be careful when reporting unused imports: the R2(fld)+import is indeed unused, but because R1(fld) is used, we should not report+fld as unused altogether.++To achieve this, we keep track of record field imports without a parent (i.e.+using the IEVar constructor) separately from other import items, using the+UnusedNames datatype.+Once we have accumulated usages, we emit warnings for unused record fields+without parents one whole group (of record fields sharing the same textual name)+at a time, and only if *all* of the record fields in the group are unused;+see 'collectUnusedNames'.++Note that this only applies to record fields imported without a parent. If we+had:++  import M1 (R1(MkR1, fld), R2(fld))+    f :: R1 -> Int+    f (MkR1 { fld = x }) = x+    g :: R2 -> Int+    g _ = 3++then of course we should report the second 'fld' as unused.+-}++ {- Note [The ImportMap] ~~~~~~~~~~~~~~~~~~~~~~~ The ImportMap is a short-lived intermediate data structure records, for@@ -1976,12 +2073,15 @@   | null unused   = return () -  -- Only one import is unused, with `SrcSpan` covering only the unused item instead of-  -- the whole import statement+  -- Some imports are unused: make the `SrcSpan` cover only the unused+  -- items instead of the whole import statement   | Just (_, L _ imports) <- ideclImportList decl-  , length unused == 1-  , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports-  = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused))+  , let unused_locs = [ locA loc | L loc ie <- imports+                                 , name <- ieNames ie+                                 , name `elem` unused ]+  , loc1 : locs <- unused_locs+  , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs )+  = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused))    -- Some imports are unused   | otherwise@@ -2294,3 +2394,4 @@ checkConName :: RdrName -> TcRn () checkConName name   = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name)+

@@ -20,13 +20,14 @@ import GHC.Settings import GHC.SysTools.BaseDir -import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class+import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory + data SettingsError   = SettingsError_MissingData String   | SettingsError_BadData String@@ -70,44 +71,51 @@   mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir         -- see Note [tooldir: How GHC finds mingw on Windows] +    -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally+    -- introduce unescaped spaces. See #24265 and #25204.+  let escaped_top_dir = escapeArg top_dir+      escaped_mtool_dir = fmap escapeArg mtool_dir++      getSetting_raw key = either pgmError pure $+        getRawSetting settingsFile mySettings key+      getSetting_topDir top key = either pgmError pure $+        getRawFilePathSetting top settingsFile mySettings key+      getSetting_toolDir top tool key =+        expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key++      getSetting :: String -> ExceptT SettingsError m String+      getSetting key = getSetting_topDir top_dir key+      getToolSetting :: String -> ExceptT SettingsError m String+      getToolSetting key = getSetting_toolDir top_dir mtool_dir key+      getFlagsSetting :: String -> ExceptT SettingsError m [String]+      getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key+        -- Make sure to unescape, as we have escaped top_dir and tool_dir.+   -- See Note [Settings file] for a little more about this file. We're   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.-  let getSetting key = either pgmError pure $-        -- Escape the 'top_dir', to make sure we don't accidentally introduce an-        -- unescaped space-        getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key-      getToolSetting :: String -> ExceptT SettingsError m String-        -- Escape the 'mtool_dir', to make sure we don't accidentally introduce-        -- an unescaped space-      getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key-  targetPlatformString <- getSetting "target platform string"+  targetPlatformString <- getSetting_raw "target platform string"   cc_prog <- getToolSetting "C compiler command"   cxx_prog <- getToolSetting "C++ compiler command"-  cc_args_str <- getToolSetting "C compiler flags"-  cxx_args_str <- getToolSetting "C++ compiler flags"+  cc_args0 <- getFlagsSetting "C compiler flags"+  cxx_args <- getFlagsSetting "C++ compiler flags"   gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"   cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0"   cpp_prog <- getToolSetting "CPP command"-  cpp_args_str <- getToolSetting "CPP flags"+  cpp_args <- map Option <$> getFlagsSetting "CPP flags"   hs_cpp_prog <- getToolSetting "Haskell CPP command"-  hs_cpp_args_str <- getToolSetting "Haskell CPP flags"+  hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags"   js_cpp_prog <- getToolSetting "JavaScript CPP command"-  js_cpp_args_str <- getToolSetting "JavaScript CPP flags"+  js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags"   cmmCpp_prog <- getToolSetting "C-- CPP command"-  cmmCpp_args_str <- getToolSetting "C-- CPP flags"+  cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags"    platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings    let unreg_cc_args = if platformUnregisterised platform                       then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]                       else []-      cpp_args    = map Option (unescapeArgs cpp_args_str)-      hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)-      js_cpp_args = map Option (unescapeArgs js_cpp_args_str)-      cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str)-      cc_args  = unescapeArgs cc_args_str ++ unreg_cc_args-      cxx_args = unescapeArgs cxx_args_str+      cc_args = cc_args0 ++ unreg_cc_args        -- The extra flags we need to pass gcc when we invoke it to compile .hc code.       --@@ -143,19 +151,19 @@   -- Config.hs one day.  -  -- Other things being equal, as and ld are simply gcc-  cc_link_args_str <- getToolSetting "C compiler link flags"+  -- Other things being equal, 'as' and 'ld' are simply 'gcc'+  cc_link_args <- getFlagsSetting "C compiler link flags"   let   as_prog  = cc_prog         as_args  = map Option cc_args         ld_prog  = cc_prog-        ld_args  = map Option (cc_args ++ unescapeArgs cc_link_args_str)+        ld_args  = map Option (cc_args ++ cc_link_args)   ld_r_prog <- getToolSetting "Merge objects command"-  ld_r_args <- getToolSetting "Merge objects flags"+  ld_r_args <- getFlagsSetting "Merge objects flags"   let ld_r         | null ld_r_prog = Nothing-        | otherwise      = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)+        | otherwise      = Just (ld_r_prog, map Option ld_r_args) -  llvmTarget <- getSetting "LLVM target"+  llvmTarget <- getSetting_raw "LLVM target"    -- We just assume on command line   lc_prog <- getSetting "LLVM llc command"

@@ -68,7 +68,7 @@ import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish -import Data.List ( genericReplicate, genericLength, intersperse+import Data.List ( genericReplicate, intersperse                  , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad@@ -373,7 +373,7 @@           -- make the arg bitmap          bits = argBits platform (reverse (map (idArgRep platform) all_args))-         bitmap_size = genericLength bits+         bitmap_size = strictGenericLength bits          bitmap = mkBitmap platform bits      body_code <- schemeER_wrk sum_szsb_args p_init body @@ -591,7 +591,7 @@      platform <- targetPlatform <$> getDynFlags      let (xs,rhss) = case binds of StgNonRec x rhs  -> ([x],[rhs])                                    StgRec xs_n_rhss -> unzip xs_n_rhss-         n_binds = genericLength xs+         n_binds = strictGenericLength xs           fvss  = map (fvsToEnv p') rhss @@ -600,7 +600,7 @@          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss           -- the arity of each rhs-         arities = map (genericLength . fst . collect) rhss+         arities = map (strictGenericLength . fst . collect) rhss           -- This p', d' defn is safe because all the items being pushed          -- are ptrs, so all have size 1 word.  d' and p' reflect the stack@@ -1700,10 +1700,14 @@          _ -> pprPanic "maybe_getCCallReturn: can't handle:"                          (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])+maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t)+  | [v] <- args   = Just (v, extract_constr_Names t)+  | otherwise+  = pprPanic "StgToByteCode: tagToEnum#"+     $ text "Expected exactly one arg, but actual args are:" <+> ppr args   where     extract_constr_Names ty            | rep_ty <- unwrapType ty@@ -1750,14 +1754,14 @@     :: StackDepth     -> Sequel     -> BCEnv-    -> Id+    -> StgArg     -> [Name]     -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names   = assert (notNull names) $-    do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)-       labels <- getLabelsBc (genericLength names)+    do (push_arg, arg_bytes) <- pushAtom d p arg+       labels <- getLabelsBc (strictGenericLength names)        label_fail <- getLabelBc        label_exit <- getLabelBc        dflags <- getDynFlags

@@ -168,7 +168,7 @@   putPaddedInt          6 own   putPaddedInt          6 grp   putPaddedInt          8 mode-  putPaddedInt         10 (st_size + pad)+  putPaddedInt         10 st_size   putByteString           "\x60\x0a"   putByteString           file   when (pad == 1) $

@@ -232,7 +232,9 @@           then does_not_exist           else throwGhcExceptionIO (ProgramError $ show err) -    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))+    does_not_exist =+      throwGhcExceptionIO $+        InstallationError (phase_name ++ ": could not execute: " ++ pgm)   builderMainLoop :: Logger -> (String -> String) -> FilePath

@@ -55,7 +55,7 @@ import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,-                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)+                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll) import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type@@ -1299,24 +1299,27 @@       text "Orphan COMPLETE pragmas not supported" $$       text "A COMPLETE pragma must mention at least one data constructor" $$       text "or pattern synonym defined in the same module."-    TcRnEmptyCase ctxt -> mkSimpleDecorated message-      where-        pp_ctxt = case ctxt of-          CaseAlt                                -> text "case expression"-          LamAlt LamCase                         -> text "\\case expression"-          ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"-          ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"-          ArrowMatchCtxt ArrowCaseAlt            -> text "case command"-          _                                      -> text "(unexpected)"-                                                    <+> pprMatchContextNoun ctxt--        message = case ctxt of-          LamAlt LamCases -> lcases_msg <+> text "expression"-          ArrowMatchCtxt (ArrowLamAlt LamCases) -> lcases_msg <+> text "command"-          _ -> text "Empty list of alternatives in" <+> pp_ctxt--        lcases_msg =-          text "Empty list of alternatives is not allowed in \\cases"+    TcRnEmptyCase ctxt reason -> mkSimpleDecorated $+      case reason of+        EmptyCaseWithoutFlag ->+          text "Empty list of alternatives in" <+> pp_ctxt+        EmptyCaseDisallowedCtxt ->+          text "Empty list of alternatives is not allowed in" <+> pp_ctxt+        EmptyCaseForall tvb ->+          vcat [ text "Empty list of alternatives in" <+> pp_ctxt+               , hang (text "checked against a forall-type:")+                      2 (pprForAll [tvb] <+> text "...")+               ]+        where+          pp_ctxt = case ctxt of+            CaseAlt                                -> text "case expression"+            LamAlt LamCase                         -> text "\\case expression"+            LamAlt LamCases                        -> text "\\cases expression"+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"+            ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> text "\\cases command"+            ArrowMatchCtxt ArrowCaseAlt            -> text "case command"+            ctxt                                   -> text "(unexpected)" <+> pprMatchContextNoun ctxt     TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $       text "accepting non-standard pattern guards" $$       nest 4 (interpp'SP guards)@@ -2988,10 +2991,11 @@       -> noHints     TcRnOrphanCompletePragma{}       -> noHints-    TcRnEmptyCase ctxt -> case ctxt of-      LamAlt LamCases -> noHints -- cases syntax doesn't support empty case.-      ArrowMatchCtxt (ArrowLamAlt LamCases) -> noHints-      _ -> [suggestExtension LangExt.EmptyCase]+    TcRnEmptyCase _ reason ->+      case reason of+        EmptyCaseWithoutFlag{}    -> [suggestExtension LangExt.EmptyCase]+        EmptyCaseDisallowedCtxt{} -> noHints+        EmptyCaseForall{}         -> noHints     TcRnNonStdGuards{}       -> [suggestExtension LangExt.PatternGuards]     TcRnDuplicateSigDecl{}

@@ -103,6 +103,7 @@   , DisabledClassExtension(..)   , TyFamsDisabledReason(..)   , TypeApplication(..)+  , BadEmptyCaseReason(..)   , HsTypeOrSigType(..)   , HsTyVarBndrExistentialFlag(..)   , TySynCycleTyCons@@ -204,7 +205,8 @@ import GHC.Core.PatSyn (PatSyn) import GHC.Core.Predicate (EqRel, predTypeEqRel) import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs)-import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag)+import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder)+ import GHC.Driver.Backend (Backend) import GHC.Unit.State (UnitState) import GHC.Utils.Misc (filterOut)@@ -3005,13 +3007,27 @@       a case expression with an empty list of alternatives without       enabling the EmptyCase extension. -     Example(s):+     Example for EmptyCaseWithoutFlag: -       case () of+       {-# LANGUAGE NoEmptyCase #-}+       f :: Void -> a+       f = \case {}    -- extension not enabled +     Example for EmptyCaseDisallowedCtxt:++       f = \cases {}   -- multi-case requires n>0 alternatives++     Example for EmptyCaseForall:++       f :: forall (xs :: Type) -> ()+       f = \case {}    -- can't match on a type argument+      Test cases: rename/should_fail/RnEmptyCaseFail+                 typecheck/should_fail/T25004   -}-  TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage+  TcRnEmptyCase :: !HsMatchContextRn+                -> !BadEmptyCaseReason+                -> TcRnMessage    {-| TcRnNonStdGuards is a warning thrown when a user uses       non-standard guards (e.g. patterns in guards) without@@ -6082,6 +6098,12 @@   = TypeApplication !(HsType GhcPs) !TypeOrKind   | TypeApplicationInPattern !(HsConPatTyArg GhcPs)   deriving Generic++-- | Why was the empty case rejected?+data BadEmptyCaseReason+  = EmptyCaseWithoutFlag+  | EmptyCaseDisallowedCtxt+  | EmptyCaseForall ForAllTyBinder  -- | Either `HsType p` or `HsSigType p`. --

@@ -319,8 +319,9 @@              -> CmdType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)-  = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)+  = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)   where+    ctxt = ArrowMatchCtxt ArrowCaseAlt     tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') } 

@@ -457,7 +457,7 @@         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut          ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty-        ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty+        ; (mult_co_wrap, matches') <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty         ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') }  tcExpr (HsIf x pred b1 b2) res_ty

@@ -1161,7 +1161,7 @@               AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con              AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps-             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon+             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)              ATyVar name _ -> failIllegalTyVal name               _ -> failWithTc $ TcRnExpectedValueId thing }

@@ -122,11 +122,12 @@                  do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys                                                       , ppr pat_tys $$ ppr rhs_ty ])-                   ; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }+                   ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }          ; return (wrap_fun <.> wrap_mult, r) }   where-    herald        = ExpectedFunTyMatches (NameThing fun_name) matches+    herald = ExpectedFunTyMatches (NameThing fun_name) matches+    mctxt  = mkPrefixFunRhs (noLocA fun_name)  funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts })@@ -146,10 +147,11 @@          ; (wrapper, (mult_co_wrap, r))             <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->-               tcMatches tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches+               tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches          ; return (wrapper <.> mult_co_wrap, r) }   where+    ctxt   = LamAlt lam_variant     herald = ExpectedFunTyLam lam_variant e              -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify @@ -167,7 +169,8 @@ -}  tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))-              => TcMatchAltChecker body    -- ^ Typecheck the alternative RHSS+              => HsMatchContextRn+              -> TcMatchAltChecker body    -- ^ Typecheck the alternative RHSS               -> Scaled TcSigmaTypeFRR     -- ^ Type of scrutinee               -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives               -> ExpRhoType                               -- ^ Type of the whole case expression@@ -175,8 +178,8 @@                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty -tcCaseMatches tc_body (Scaled scrut_mult scrut_ty) matches res_ty-  = tcMatches tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches+tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty+  = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches  -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType@@ -223,23 +226,30 @@  -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body, Outputable (body GhcTc))-          => TcMatchAltChecker body+          => HsMatchContextRn+          -> TcMatchAltChecker body           -> [ExpPatType]             -- ^ Expected pattern types.           -> ExpRhoType               -- ^ Expected result-type of the Match.           -> MatchGroup GhcRn (LocatedA (body GhcRn))           -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches-                                     , mg_ext = origin })+tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches+                                          , mg_ext = origin })   | null matches  -- Deal with case e of {}     -- Since there are no branches, no one else will fill in rhs_ty     -- when in inference mode, so we must do it ourselves,     -- here, using expTypeToType   = do { tcEmitBindingUsage bottomUE-       ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)+         -- See Note [Pattern types for EmptyCase]+       ; let vis_pat_tys = filter isVisibleExpPatType pat_tys+       ; pat_ty <- case vis_pat_tys of+           [ExpFunPatTy t]      -> scaledExpTypeToType t+           [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)+           []                   -> panic "tcMatches: no arguments in EmptyCase"+           _t1:(_t2:_ts)        -> panic "tcMatches: multiple arguments in EmptyCase"        ; rhs_ty  <- expTypeToType rhs_ty        ; return (idHsWrapper, MG { mg_alts = L l []-                                 , mg_ext = MatchGroupTc pat_tys rhs_ty origin+                                 , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin                                  }) }    | otherwise@@ -261,6 +271,43 @@       where         match_fun_pat_ty (ExpFunPatTy t)  = Just t         match_fun_pat_ty ExpForAllPatTy{} = Nothing++{- Note [Pattern types for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tcMatches, we might encounter an empty list of matches if the user wrote+`case x of {}` or `\case {}`.++* First of all, both `case x of {}` and `\case {}` match on exactly one visible+  argument, which follows from++    checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity+    checkArgCounts (MG { mg_alts = L _ [] })+      = return 1+    ...++  So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise.++  Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it+  must have been rejected earlier in `rnMatchGroup`.++  Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`,+  etc) are not considered here because there is no syntax to construct them with+  an empty list of alternatives.++* With lambda-case, we run the risk of trying to match on a type argument:++    f :: forall (xs :: Type) -> ()+    f = \case {}++  This is not valid and it used to trigger a panic in pmcMatches (#25004).+  We reject it by inspecting the expected pattern type:++    ; pat_ty <- case vis_pat_tys of+        [ExpFunPatTy t]      -> ...    -- value argument, ok+        [ExpForAllPatTy tvb] -> ...    -- type argument, error!++  Test case: typecheck/should_fail/T25004+-}  ------------- tcMatch :: (AnnoBody body)

@@ -32,7 +32,7 @@ import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Multiplicity ( scaledThing )-import GHC.Core.Unify ( ruleMatchTyKiX )+import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart )  import GHC.Types.Name import GHC.Types.Name.Set@@ -105,21 +105,25 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })   = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls  <+> ppr tys) -       ; if |  isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys+       ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys             -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]                -- Update /both/ inert_cans /and/ inert_solved_dicts.                updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->-               inerts { inert_cans         = updDicts (filterDicts (not_ip_for str_ty)) ics-                      , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }-            |  otherwise+               inerts { inert_cans         = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics+                      , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }+            | otherwise             -> return ()         -- Add the new constraint to the inert set        ; updInertCans (updDicts (addDict dict_ct)) }   where-    not_ip_for :: Type -> DictCt -> Bool-    not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })-      = not (mentionsIP str_ty cls tys)+    -- Does this class constraint or any of its superclasses mention+    -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?+    does_not_mention_ip_for :: Type -> DictCt -> Bool+    does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })+      = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys+        -- See Note [Using typesAreApart when calling mentionsIP]+        -- in GHC.Core.Predicate  canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints:@@ -201,7 +205,7 @@ * In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have    (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. -* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove  any+* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any   existing [G] (?x :: ty'), regardless of ty'.  * Wrinkle (SIP1): we must be careful of superclasses.  Consider@@ -221,7 +225,7 @@   An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).   But it could happen for `class xx => D xx where ...` and the constraint D   (?x :: int).  This corner (constraint-kinded variables instantiated with-  implicit parameter constraints) is not well explorered.+  implicit parameter constraints) is not well explored.    Example in #14218, and #23761 

@@ -158,7 +158,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Unify -import GHC.Builtin.Names ( unsatisfiableClassNameKey )+import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )  import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep@@ -168,6 +168,7 @@ import GHC.Core.Reduction import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Unify (typesAreApart)  import GHC.Types.Name import GHC.Types.TyThing@@ -177,13 +178,13 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.Set( elementOfUniqSet ) -import GHC.Unit.Module ( HasModule, getModule, extractModule )+import GHC.Unit.Module ( HasModule, getModule, extractModule, primUnit, moduleUnit, ghcInternalUnit, bignumUnit) import qualified GHC.Rename.Env as TcM  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Misc (HasDebugCallStack, (<||>))  import GHC.Data.Bag as Bag import GHC.Data.Pair@@ -478,14 +479,92 @@ updSolvedDicts :: InstanceWhat -> DictCt -> TcS () -- Conditionally add a new item in the solved set of the monad -- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet-updSolvedDicts what dict_ct@(DictCt { di_ev = ev })+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })   | isWanted ev   , instanceReturnsDictCon what-  = do { traceTcS "updSolvedDicts:" $ ppr dict_ct+  = do { is_callstack    <- is_tyConTy isCallStackTy        callStackTyConName+       ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName+       ; let contains_callstack_or_exceptionCtx =+               mentionsIP+                 (const True)+                    -- NB: the name of the call-stack IP is irrelevant+                    -- e.g (?foo :: CallStack) counts!+                 (is_callstack <||> is_exceptionCtx)+                 cls tys+       -- See Note [Don't add HasCallStack constraints to the solved set]+       ; unless contains_callstack_or_exceptionCtx $+    do { traceTcS "updSolvedDicts:" $ ppr dict_ct        ; updInertSet $ \ ics ->-         ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } }+           ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }+       } }   | otherwise   = return ()+  where++    -- Return a predicate that decides whether a type is CallStack+    -- or ExceptionContext, accounting for e.g. type family reduction, as+    -- per Note [Using typesAreApart when calling mentionsIP].+    --+    -- See Note [Using isCallStackTy in mentionsIP].+    is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)+    is_tyConTy is_eq tc_name+      = do {  mb_tc <- wrapTcS $ do+                mod <- tcg_mod <$> TcM.getGblEnv+                if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]+                then return Nothing+                else Just <$> TcM.tcLookupTyCon tc_name+           ; case mb_tc of+              Just tc ->+                return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))+              Nothing ->+                return is_eq+           }++{- Note [Don't add HasCallStack constraints to the solved set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not add solved Wanted dictionaries that mention HasCallStack constraints+to the solved set, or we might fail to accumulate the proper call stack, as was+reported in #25529.++Recall that HasCallStack constraints (and the related HasExceptionContext+constraints) are implicit parameter constraints, and are accumulated as per+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.++When we solve a Wanted that contains a HasCallStack constraint, we don't want+to cache the result, because re-using that solution means re-using the call-stack+in a different context!++See also Note [Shadowing of implicit parameters], which deals with a similar+problem with Given implicit parameter constraints.++Note [Using isCallStackTy in mentionsIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To implement Note [Don't add HasCallStack constraints to the solved set],+we need to check whether a constraint contains a HasCallStack or HasExceptionContext+constraint. We do this using the 'mentionsIP' function, but as per+Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:++  mentionsIP+    (const True) -- (ignore the implicit parameter string)+    (isCallStackTy <||> isExceptionContextTy)++because this does not account for e.g. a type family that reduces to CallStack.+The predicate we want to use instead is:++    \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)++However, this is made difficult by the fact that CallStack and ExceptionContext+are not wired-in types; they are only known-key. This means we must look them+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle+of typechecking ghc-internal and these data-types have not been typechecked yet!++In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'+logic.++Note that it would be somewhat painful to wire-in ExceptionContext: at the time+of writing (March 2025), this would require wiring in the ExceptionAnnotation+class, as well as SomeExceptionAnnotation, which is a data type with existentials.+-}  getSolvedDicts :: TcS (DictMap DictCt) getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }

@@ -166,7 +166,7 @@     IP "callStack" CallStack   See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence -* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by+* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by   pushing the call-site info on the stack, and changing the CtOrigin   to record that has been done.    Bind:  s1 = pushCallStack <site-info> s2

@@ -4752,6 +4752,8 @@         ; traceTc "Done validity of data con" $           vcat [ ppr con                , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)+               , text "Datacon src bangs:" <+> ppr (dataConSrcBangs con)+               , text "Datacon impl bangs:" <+> ppr (dataConImplBangs con)                , text "Datacon rep type:" <+> ppr (dataConRepType con)                , text "Datacon display type:" <+> ppr data_con_display_type                , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))

@@ -280,7 +280,7 @@     thing <- tcLookupGlobal name     case thing of         AConLike cl -> return cl-        ATyCon tc   -> failIllegalTyCon WL_Constructor tc+        ATyCon  {}  -> failIllegalTyCon WL_Constructor name         _           -> wrongThingErr WrongThingConLike (AGlobal thing) name  tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent@@ -353,19 +353,20 @@     lookupThing = tcLookupGlobal  -- Illegal term-level use of type things-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a+failIllegalTyCon :: WhatLooking -> Name -> TcM a failIllegalTyVal :: Name -> TcM a (failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)   where-    fail_tycon what_looking tc = do+    fail_tycon what_looking tc_nm = do       gre <- getGlobalRdrEnv-      let nm = tyConName tc-          pprov = case lookupGRE_Name gre nm of+      let mb_gre = lookupGRE_Name gre tc_nm+          pprov = case mb_gre of                       Just gre -> nest 2 (pprNameProvenance gre)                       Nothing  -> empty-          err | isClassTyCon tc = ClassTE-              | otherwise       = TyConTE-      fail_with_msg what_looking dataName nm pprov err+          err = case greInfo <$> mb_gre of+            Just (IAmTyCon ClassFlavour) -> ClassTE+            _ -> TyConTE+      fail_with_msg what_looking dataName tc_nm pprov err      fail_tyvar nm =       let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))

@@ -1535,39 +1535,87 @@   --- Given a type already assumed to have been normalized by topNormaliseType,--- unpackable_type_datacons ty = Just datacons--- iff ty is of the form---     T ty1 .. tyn--- and T is an algebraic data type (not newtype), in which no data--- constructors have existentials, and datacons is the list of data--- constructors of T. unpackable_type_datacons :: Type -> Maybe [DataCon]+-- Given a type already assumed to have been normalized by topNormaliseType,+--    unpackable_type_datacons (T ty1 .. tyn) = Just datacons+-- iff the type can be unpacked (see Note [Unpacking GADTs and existentials])+-- and `datacons` are the data constructors of T unpackable_type_datacons ty   | Just (tc, _) <- splitTyConApp_maybe ty-  , not (isNewTyCon tc)  -- Even though `ty` has been normalised, it could still-                         -- be a /recursive/ newtype, so we must check for that+  , not (isNewTyCon tc)+      -- isNewTyCon: even though `ty` has been normalised, whic includes looking+      -- through newtypes, it could still be a /recursive/ newtype, so we must+      -- check for that case   , Just cons <- tyConDataCons_maybe tc-  , not (null cons)      -- Don't upack nullary sums; no need.-                         -- They already take zero bits-  , all (null . dataConExTyCoVars) cons-  = Just cons -- See Note [Unpacking GADTs and existentials]+  , unpackable_cons cons+  = Just cons   | otherwise   = Nothing+  where+    unpackable_cons :: [DataCon] -> Bool+    -- True if we can unpack a value of type (T t1 .. tn),+    -- where T is an algebraic data type with these constructors+    -- See Note [Unpacking GADTs and existentials]+    unpackable_cons []   -- Don't unpack nullary sums; no need.+      = False            -- They already take zero bits; see (UC0) +    unpackable_cons [con]   -- Exactly one data constructor; see (UC1)+      = null (dataConExTyCoVars con)++    unpackable_cons cons  -- More than one data constructor; see (UC2)+      = all isVanillaDataCon cons+ {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is nothing stopping us unpacking a data type with equality-components, like-  data Equal a b where-    Equal :: Equal a a+Can we unpack a value of an algebraic data type T? For example+   data D a = MkD {-# UNPACK #-} (T a)+Can we unpack that (T a) field? -And it'd be fine to unpack a product type with existential components-too, but that would require a bit more plumbing, so currently we don't.+Three cases to consider in `unpackable_cons` -So for now we require: null (dataConExTyCoVars data_con)-See #14978+(UC0) No data constructors; a nullary sum type.  This already takes zero+      bits so there is no point in unpacking it.++(UC1) Single-constructor types (products).  We can just represent it by+   its fields. For example, if `T` is defined as:+      data T a = MkT a a Int+   then we can unpack it as follows.  The worker for MkD takes three unpacked fields:+       data D a = MkD a a Int+       $MkD :: T a -> D a+       $MkD (MkT a1 a2 i) = MkD a1 a2 i++   We currently /can't/ do this if T has existentially-bound type variables,+   hence:   null (dataConExTyCoVars con)   in `unpackable_cons`.+   But see also (UC3) below.++   But we /can/ do it for (some) GADTs, such as:+      data Equal a b where { Equal :: Equal a a }+      data Wom a where { Wom1 :: Int -> Wom Bool }+   We will get a MkD constructor that includes some coercion arguments,+   but that is fine.   See #14978.  We still can't accommodate existentials,+   but these particular examples don't use existentials.++(UC2) Multi-constructor types, e.g.+        data T a = T1 a | T2 Int a+  Here we unpack the field to an unboxed sum type, thus:+    data D a = MkD (# a | (# Int, a #) #)++  However, now we can't deal with GADTs at all, because we'd need an+  unboxed sum whose component was a unboxed tuple, whose component(s)+  have kind (CONSTRAINT r); and that's not well-kinded.  Hence the+    all isVanillaDataCon+  condition in `unpackable_cons`. See #25672.++(UC3)  For single-constructor types, with some more plumbing we could+   allow existentials. e.g.+       data T a = forall b. MkT a (b->Int) b+   could unpack to+       data D a = forall b. MkD a (b->Int) b+       $MkD :: T a -> D a+       $MkD (MkT @b x f y) = MkD @b x f y+   Eminently possible, but more plumbing needed.+  Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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