ghc-lib 9.6.2.20231121 → 9.6.3.20231014

raw patch · 42 files changed

+1411/−628 lines, 42 filesdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +42/−21
• compiler/GHC/CmmToAsm/Ppr.hs +4/−0
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +24/−2
• compiler/GHC/Core/Opt/DmdAnal.hs +122/−84
• compiler/GHC/Core/Opt/SpecConstr.hs +8/−7
• compiler/GHC/Core/Opt/Specialise.hs +28/−5
• compiler/GHC/CoreToStg/Prep.hs +1/−1
• compiler/GHC/Driver/CodeOutput.hs +1/−1
• compiler/GHC/Driver/Config/StgToCmm.hs +2/−0
• compiler/GHC/Driver/GenerateCgIPEStub.hs +202/−95
• compiler/GHC/Driver/Main.hs +30/−10
• compiler/GHC/Driver/Make.hs +16/−16
• compiler/GHC/Driver/Pipeline.hs +18/−7
• compiler/GHC/HsToCore/Match.hs +71/−15
• compiler/GHC/HsToCore/Pmc.hs +3/−3
• compiler/GHC/Iface/Recomp/Flags.hs +4/−1
• compiler/GHC/Linker/Static.hs +1/−1
• compiler/GHC/Stg/Debug.hs +2/−2
• compiler/GHC/Stg/InferTags/Rewrite.hs +7/−10
• compiler/GHC/Stg/Lint.hs +38/−29
• compiler/GHC/Stg/Unarise.hs +26/−19
• compiler/GHC/StgToCmm/Closure.hs +110/−8
• compiler/GHC/StgToCmm/Env.hs +2/−2
• compiler/GHC/StgToCmm/Foreign.hs +23/−7
• compiler/GHC/StgToCmm/Monad.hs +4/−2
• compiler/GHC/StgToCmm/Prim.hs +181/−111
• compiler/GHC/StgToCmm/Prof.hs +13/−10
• compiler/GHC/StgToCmm/Utils.hs +78/−16
• compiler/GHC/Tc/Errors.hs +44/−23
• compiler/GHC/Tc/Gen/Bind.hs +22/−2
• compiler/GHC/Tc/Gen/Expr.hs +27/−2
• compiler/GHC/Tc/Gen/Head.hs +1/−1
• compiler/GHC/Tc/Solver.hs +88/−23
• compiler/GHC/Tc/Solver/Canonical.hs +2/−1
• compiler/GHC/Tc/Solver/Interact.hs +48/−28
• compiler/GHC/Tc/Solver/Monad.hs +24/−24
• compiler/GHC/Tc/TyCl/Utils.hs +7/−4
• compiler/GHC/Tc/Utils/TcMType.hs +52/−9
• compiler/GHC/Tc/Utils/Unify.hs +22/−23
• compiler/GHC/Tc/Utils/Zonk.hs +5/−1
• ghc-lib.cabal +2/−2
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +6/−0

@@ -695,12 +695,16 @@     -- 1. Compute Reg +/- n directly.     --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.     CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      | n > 0 && n < 4096+      , w == W32 || w == W64 -- Work around #23749+      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg     CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      | n > 0 && n < 4096+      , w == W32 || w == W64 -- Work around #23749+      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.       where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))             r' = getRegisterReg plat reg@@ -964,6 +968,7 @@     isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)      -- N.B. MUL does not set the overflow flag.+    -- These implementations are based on output from GCC 11.     do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register     do_mul_may_oflo w@W64 x y = do         (reg_x, _format_x, code_x) <- getSomeReg x@@ -977,31 +982,47 @@             SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`             CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`             CSET (OpReg w dst) NE)++    do_mul_may_oflo W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL`+            ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL`+            CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL`+            CSET (OpReg W32 dst) NE)+     do_mul_may_oflo w x y = do         (reg_x, _format_x, code_x) <- getSomeReg x         (reg_y, _format_y, code_y) <- getSomeReg y-        let tmp_w = case w of-                      W32 -> W64-                      W16 -> W32-                      W8  -> W32-                      _   -> panic "do_mul_may_oflo: impossible"-        -- This will hold the product-        tmp <- getNewRegNat (intFormat tmp_w)-        let ext_mode = case w of-                         W32 -> ESXTW-                         W16 -> ESXTH-                         W8  -> ESXTB-                         _   -> panic "do_mul_may_oflo: impossible"-            mul = case w of-                    W32 -> SMULL-                    W16 -> MUL-                    W8  -> MUL-                    _   -> panic "do_mul_may_oflo: impossible"+        tmp1 <- getNewRegNat II32+        tmp2 <- getNewRegNat II32+        let extend dst arg =+              case w of+                W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg)+                W8  -> SXTB (OpReg W32 dst) (OpReg W32 arg)+                _   -> panic "unreachable"+            cmp_ext_mode =+              case w of+                W16 -> EUXTH+                W8  -> EUXTB+                _   -> panic "unreachable"+            width = widthInBits w+            opInt = OpImm . ImmInt+         return $ Any (intFormat w) (\dst ->             code_x `appOL`             code_y `snocOL`-            mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`-            CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`+            extend tmp1 reg_x `snocOL`+            extend tmp2 reg_y `snocOL`+            MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL`+            SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL`+            UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL`+            CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL`             CSET (OpReg w dst) NE)  -- | Is a given number encodable as a bitmask immediate?

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

@@ -969,16 +969,38 @@          return (Fixed format eax code) -     imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo W8 a b = do+         -- The general case (W16, W32, W64) doesn't work for W8 as its+         -- multiplication doesn't use two registers.+         --+         -- The plan is:+         -- 1. truncate and sign-extend a and b to 8bit width+         -- 2. multiply a' = a * b in 32bit width+         -- 3. copy and sign-extend 8bit from a' to c+         -- 4. compare a' and c: they are equal if there was no overflow+         (a_reg, a_code) <- getNonClobberedReg a+         (b_reg, b_code) <- getNonClobberedReg b+         let+             code = a_code `appOL` b_code `appOL`+                        toOL [+                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),+                           IMUL II32 (OpReg b_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg a_reg) (OpReg eax),+                           CMP II16 (OpReg a_reg) (OpReg eax),+                           SETCC NE (OpReg eax)+                        ]+         return (Fixed II8 eax code)     imulMayOflo rep a b = do          (a_reg, a_code) <- getNonClobberedReg a          b_code <- getAnyReg b          let              shift_amt  = case rep of+                           W16 -> 15                            W32 -> 31                            W64 -> 63-                           _ -> panic "shift_amt"+                           w -> panic ("shift_amt: " ++ show w)               format = intFormat rep              code = a_code `appOL` b_code eax `appOL`

@@ -98,28 +98,35 @@       where         anal_body env'           | WithDmdType body_ty bs' <- go env' bs-          = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'+          = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'      cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]     cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') -    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType-    add_exported_uses env = foldl' (add_exported_use env)+    keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv+    -- See Note [Absence analysis for stable unfoldings and RULES]+    -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in+    -- orphan RULES+    keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids)) -    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@-    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.-    -- See Note [Analysing top-level bindings].-    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType-    add_exported_use env dmd_ty id-      | isExportedId id || elemVarSet id rule_fvs-      -- See Note [Absence analysis for stable unfoldings and RULES]-      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))-      | otherwise-      = dmd_ty+    is_root :: Id -> Bool+    is_root id = isExportedId id || elemVarSet id rule_fvs      rule_fvs :: IdSet     rule_fvs = rulesRhsFreeIds rules +demandRoot :: AnalEnv -> Id -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoot env id = fst (dmdAnalStar env topDmd (Var id))++demandRoots :: AnalEnv -> [Id] -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)++demandRootSet :: AnalEnv -> IdSet -> DmdEnv+demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)+  -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative+ -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings -- that satisfy this function. --@@ -344,7 +351,7 @@      -- See Note [Absence analysis for stable unfoldings and RULES]     rule_fvs           = bndrRuleAndUnfoldingIds id-    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs+    final_ty           = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs  -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS).@@ -361,18 +368,18 @@ dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of   NonRec id rhs-    | (env', lazy_fv, id1, rhs1) <-+    | (env', weak_fv, id1, rhs1) <-         dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs-    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)+    -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only)   Rec pairs-    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs-    -> do_rest env' lazy_fv pairs' Rec+    | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' weak_fv pairs' Rec   where-    do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')+    do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')       where         WithDmdType body_ty body'        = anal_body env'         -- see Note [Lazy and unleashable free variables]-        dmd_ty                          = addLazyFVs body_ty lazy_fv+        dmd_ty                          = addWeakFVs body_ty weak_fv         WithDmdType final_ty id_dmds    = findBndrsDmds env' dmd_ty (strictMap fst pairs1)         -- Important to force this as build_bind might not force it.         !pairs2                         = strictZipWith do_one pairs1 id_dmds@@ -409,14 +416,14 @@ dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*             -> CoreExpr-            -> (PlusDmdArg, CoreExpr)+            -> (DmdEnv, CoreExpr) dmdAnalStar env (n :* sd) e   -- NB: (:*) expands AbsDmd and BotDmd as needed   | WithDmdType dmd_ty e' <- dmdAnal env sd e   , n' <- anticipateANF e n       -- See Note [Anticipating ANF in demand analysis]       -- and Note [Analysing with absent demand]-  = (toPlusDmdArg $ multDmdType n' dmd_ty, e')+  = (discardArgDmds $ multDmdType n' dmd_ty, e')  -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv@@ -429,13 +436,13 @@ dmdAnal' _ _ (Lit lit)     = WithDmdType nopDmdType (Lit lit) dmdAnal' _ _ (Type ty)     = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co)-  = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co)+  = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co)  dmdAnal' env dmd (Var var)   = WithDmdType (dmdTransform env var dmd) (Var var)  dmdAnal' env dmd (Cast e co)-  = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co)+  = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co)   where     WithDmdType dmd_ty e' = dmdAnal env dmd e @@ -533,7 +540,7 @@           = alt_ty2          WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut-        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty+        res_ty             = alt_ty3 `plusDmdType` discardArgDmds scrut_ty     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd@@ -570,7 +577,7 @@           = deferAfterPreciseException alt_ty1           | otherwise           = alt_ty1-        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty+        res_ty               = scrut_ty `plusDmdType` discardArgDmds alt_ty2      in --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut@@ -1031,7 +1038,7 @@   --   * Case and constructor field binders   | otherwise   = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $-    unitDmdType (unitVarEnv var (C_11 :* sd))+    noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))  {- ********************************************************************* *                                                                      *@@ -1039,6 +1046,10 @@ *                                                                      * ********************************************************************* -} +-- | An environment in which all demands are weak according to 'isWeakDmd'.+-- See Note [Lazy and unleashable free variables].+type WeakDmds = VarEnv Demand+ -- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature -- for the LetDown rule. It works as follows: --@@ -1053,13 +1064,13 @@   -> RecFlag   -> AnalEnv -> SubDemand   -> Id -> CoreExpr-  -> (AnalEnv, DmdEnv, Id, CoreExpr)+  -> (AnalEnv, WeakDmds, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $-    (final_env, lazy_fv, final_id, final_rhs)+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $+    (final_env, weak_fvs, final_id, final_rhs)   where     threshold_arity = thresholdArity id rhs @@ -1077,12 +1088,11 @@       = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd      WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs-    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty-    -- See Note [Boxity for bottoming functions]-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div+    DmdType rhs_env rhs_dmds = rhs_dmd_ty+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' (de_div rhs_env)                                   `orElse` (rhs_dmds, rhs') -    sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)+    sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds)      opts       = ae_opts env     final_id   = setIdDmdAndBoxSig opts id sig@@ -1100,16 +1110,20 @@     --        we'd have to do an additional iteration. reuseEnv makes sure that     --        we never get used-once info for FVs of recursive functions.     --        See #14816 where we try to get rid of reuseEnv.-    rhs_fv1 = case rec_flag of-                Recursive    -> reuseEnv rhs_fv-                NonRecursive -> rhs_fv+    rhs_env1 = case rec_flag of+                Recursive    -> reuseEnv rhs_env+                NonRecursive -> rhs_env      -- See Note [Absence analysis for stable unfoldings and RULES]-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id+    rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)      -- See Note [Lazy and unleashable free variables]-    !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2+    !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 +splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)+splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)+  where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs+ thresholdArity :: Id -> CoreExpr -> Arity -- See Note [Demand signatures are computed for a threshold arity based on idArity] thresholdArity fn rhs@@ -1365,8 +1379,8 @@  Note [Absence analysis for stable unfoldings and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Ticket #18638 shows that it's really important to do absence analysis-for stable unfoldings. Consider+Among others, tickets #18638 and #23208 show that it's really important to treat+stable unfoldings as demanded. Consider     g = blah @@ -1383,24 +1397,48 @@  Now if f is subsequently inlined, we'll use 'g' and ... disaster. -SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands-on its free variables) so that no variable mentioned in its unfolding-is Absent.  This is done by the function Demand.keepAliveDmdEnv.+SOLUTION: if f has a stable unfolding, treat every free variable as a+/demand root/, that is: Analyse it as if it was a variable occuring in a+'topDmd' context. This is done in `demandRoot` (which we also use for exported+top-level ids). Do the same for Ids free in the RHS of any RULES for f. -ALSO: do the same for Ids free in the RHS of any RULES for f.+Wrinkles: -PS: You may wonder how it can be that f's optimised RHS has somehow-discarded 'g', but when f is inlined we /don't/ discard g in the same-way. I think a simple example is-   g = (a,b)-   f = \x.  fst g-   {-# INLINE f #-}+  (W1) You may wonder how it can be that f's optimised RHS has somehow+    discarded 'g', but when f is inlined we /don't/ discard g in the same+    way. I think a simple example is+       g = (a,b)+       f = \x.  fst g+       {-# INLINE f #-} -Now f's optimised RHS will be \x.a, but if we change g to (error "..")-(since it is apparently Absent) and then inline (\x. fst g) we get-disaster.  But regardless, #18638 was a more complicated version of-this, that actually happened in practice.+    Now f's optimised RHS will be \x.a, but if we change g to (error "..")+    (since it is apparently Absent) and then inline (\x. fst g) we get+    disaster.  But regardless, #18638 was a more complicated version of+    this, that actually happened in practice. +  (W2) You might wonder why we don't simply take the free vars of the+    unfolding/RULE and map them to topDmd. The reason is that any of the free vars+    might have demand signatures themselves that in turn demand transitive free+    variables and that we hence need to unleash! This came up in #23208.+    Consider++       err :: Int -> b+       err = error "really important message"++       sg :: Int -> Int+       sg _ = case err of {}  -- Str=<1B>b {err:->S}++       g :: a -> a  -- g is exported+       g x = x+       {-# RULES "g" g @Int = sg #-}++    Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur+    in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`+    because it occurs in the RULEs of `g` (which is exported), we better unleash+    the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'+    for `sg`, failing to unleash the signature and hence observed an absent+    error instead of the `really important message`.+ Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give DataCon wrappers a (necessarily flat) demand signature in@@ -2084,8 +2122,7 @@        -> AnalEnv                            -- Does not include bindings for this binding        -> SubDemand        -> [(Id,CoreExpr)]-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info-+       -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info dmdFix top_lvl env let_dmd orig_pairs   = loop 1 initial_pairs   where@@ -2096,33 +2133,33 @@      -- If fixed-point iteration does not yield a result we use this instead     -- See Note [Safe abortion in the fixed-point iteration]-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)+    abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)])+    abort = (env, weak_fv', zapped_pairs)+      where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs)             -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs+            weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs'+            weak_fv'     = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs             zapped_pairs = zapIdDmdSig pairs'      -- The fixed-point varies the idDmdSig field of the binders, and terminates if that     -- annotation does not change any more.-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)])     loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)                    --                                   | (id,_) <- pairs]) $                    loop' n pairs      loop' n pairs-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')+      | found_fixpoint = (final_anal_env, weak_fv, pairs')       | n == 10        = abort       | otherwise      = loop (n+1) pairs'       where         found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs         first_round       = n == 1-        (lazy_fv, pairs') = step first_round pairs+        (weak_fv, pairs') = step first_round pairs         final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs') -    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])-    step first_round pairs = (lazy_fv, pairs')+    step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])+    step first_round pairs = (weak_fv, pairs')       where         -- In all but the first iteration, delete the virgin flag         start_env | first_round = env@@ -2130,17 +2167,17 @@          start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) -        !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs+        !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs                 -- mapAccumL: Use the new signature to do the next pair                 -- The occurrence analyser has arranged them in a good order                 -- so this can significantly reduce the number of iterations needed -        my_downRhs (env, lazy_fv) (id,rhs)+        my_downRhs (env, weak_fv) (id,rhs)           = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $-            ((env', lazy_fv'), (id', rhs'))+            ((env', weak_fv'), (id', rhs'))           where-            !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs-            !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1+            !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            !weak_fv'                    = plusVarEnv_C plusDmd weak_fv weak_fv1      zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]     zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]@@ -2214,23 +2251,24 @@ *                                                                      * ********************************************************************* -} -unitDmdType :: DmdEnv -> DmdType-unitDmdType dmd_env = DmdType dmd_env [] topDiv+noArgsDmdType :: DmdEnv -> DmdType+noArgsDmdType dmd_env = DmdType dmd_env []  coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv co = coercionsDmdEnv [co]  coercionsDmdEnv :: [Coercion] -> DmdEnv-coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)-                      -- The VarSet from coVarsOfCos is really a VarEnv Var+coercionsDmdEnv cos+  = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos+  -- The VarSet from coVarsOfCos is really a VarEnv Var  addVarDmd :: DmdType -> Var -> Demand -> DmdType-addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res+addVarDmd (DmdType fv ds) var dmd+  = DmdType (addVarDmdEnv fv var dmd) ds -addLazyFVs :: DmdType -> DmdEnv -> DmdType-addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs+addWeakFVs :: DmdType -> WeakDmds -> DmdType+addWeakFVs dmd_ty weak_fvs+  = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs         -- Using plusDmdType (rather than just plus'ing the envs)         -- is vital.  Consider         --      let f = \x -> (x,y)@@ -2239,7 +2277,7 @@         -- demand with the bottom coming up from 'error'         --         -- I got a loop in the fixpointer without this, due to an interaction-        -- with the lazy_fv filtering in dmdAnalRhsSig.  Roughly, it was+        -- with the weak_fv filtering in dmdAnalRhsSig.  Roughly, it was         --      letrec f n x         --          = letrec g y = x `fatbar`         --                         letrec h z = z + ...g...@@ -2340,14 +2378,14 @@  But now the signature lies! (Missing variables are assumed to be absent.) To make up for this, the code that analyses the binding keeps the demand on those-variable separate (usually called "lazy_fv") and adds it to the demand of the+variable separate (usually called "weak_fv") and adds it to the demand of the whole binding later.  What if we decide _not_ to store a strictness signature for a binding at all, as we do when aborting a fixed-point iteration? The we risk losing the information that the strict variables are being used. In that case, we take all free variables mentioned in the (unsound) strictness signature, conservatively approximate the-demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".+demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix".   ************************************************************************

@@ -2095,15 +2095,16 @@ calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs   = ( spec_lam_bndrs_w_dmds     , spec_call_args-    , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div )+    , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) )   where-    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn+    DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn+    spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b]      val_pats   = filterOut isTypeArg pats                  -- Value args at call sites, used to determine how many demands to drop-                 -- from the original functions demand and for setting up dmd_env.-    dmd_env    = go emptyVarEnv fn_dmds val_pats-    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+                 -- from the original functions demand and for setting up arg_dmd_env.+    arg_dmd_env = go emptyVarEnv fn_dmds val_pats+    qvar_dmds  = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]     extra_dmds = dropList val_pats fn_dmds      -- Annotate the variables with the strictness information from@@ -2127,12 +2128,12 @@     set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds                                | otherwise = setIdDemandInfo v d : set_dmds vs ds' -    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv+    go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand     -- We've filtered out all the type patterns already     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats     go env _      _                = env -    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv+    go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand     go_one env d          (Var v) = extendVarEnv_C plusDmd env v d     go_one env (_n :* cd) e -- NB: _n does not have to be strict       | (Var _, args) <- collectArgs e

@@ -1495,7 +1495,9 @@              -- Destroying demand info is not terrible; specialisation is              -- always followed soon by demand analysis. -             body_env2 = body_env1 `extendInScope` fn3+             body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds+                                   `extendInScope` fn3+                                   -- bringFloatedDictsIntoScope: see #23567         ; (body', body_uds) <- do_body body_env2 @@ -2490,6 +2492,12 @@ specArgFreeIds UnspecType    = emptyVarSet specArgFreeIds UnspecArg     = emptyVarSet +specArgFreeVars :: SpecArg -> VarSet+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty+specArgFreeVars (SpecDict dx) = exprFreeVars dx+specArgFreeVars UnspecType    = emptyVarSet+specArgFreeVars UnspecArg     = emptyVarSet+ isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True isSpecDict _             = False@@ -2798,6 +2806,12 @@  Note [Specialising polymorphic dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Note June 2023: This has proved to be quite a tricky optimisation to get right+see (#23469, #23109, #21229, #23445) so it is now guarded by a flag+`-fpolymorphic-specialisation`.++ Consider     class M a where { foo :: a -> Int } @@ -2988,14 +3002,23 @@   -------------------------------------------------------------singleCall :: Id -> [SpecArg] -> UsageDetails-singleCall id args+singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails+singleCall spec_env id args   = MkUD {ud_binds = emptyFDBs,           ud_calls = unitDVarEnv id $ CIS id $                      unitBag (CI { ci_key  = args                                  , ci_fvs  = call_fvs }) }   where-    call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args+    call_fvs =+      foldr (unionVarSet . free_var_fn) emptyVarSet args++    free_var_fn =+      if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)+        then specArgFreeIds+        else specArgFreeVars+++         -- specArgFreeIds: we specifically look for free Ids, not TyVars         --    see (MP1) in Note [Specialising polymorphic dictionaries]         --@@ -3014,7 +3037,7 @@   | wantCallsFor env f    -- We want it, and...   , not (null ci_key)     -- this call site has a useful specialisation   = -- pprTrace "mkCallUDs: keeping" _trace_doc-    singleCall f ci_key+    singleCall env f ci_key    | otherwise  -- See also Note [Specialisations already covered]   = -- pprTrace "mkCallUDs: discarding" _trace_doc

@@ -1111,7 +1111,7 @@         where           depth = val_args args           stricts = case idDmdSig v of-                            DmdSig (DmdType _ demands _)+                            DmdSig (DmdType _ demands)                               | listLengthCmp demands depth /= GT -> demands                                     -- length demands <= depth                               | otherwise                         -> []

@@ -295,7 +295,7 @@              -- wrapper code mentions the ffi_arg type, which comes from ffi.h             ffi_includes-              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"+              | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"               | otherwise = ""          stub_h_file_exists

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

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

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

@@ -669,7 +669,6 @@     guessOutputFile     hsc_env <- getSession -    let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env     let interp = hscInterp hsc_env @@ -745,16 +744,14 @@                     Just n  -> return n      setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env-    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do+    (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do       hsc_env <- getSession       liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan-    setSession hsc_env1+    modifySession (addDepsToHscEnv new_deps)     case upsweep_ok of       Failed -> loadFinish upsweep_ok       Succeeded -> do           liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")-          -- Clean up after ourselves-          liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags           loadFinish upsweep_ok  @@ -1229,14 +1226,13 @@     -> Maybe Messager     -> M.Map ModNodeKeyWithUid HomeModInfo     -> [BuildPlan]-    -> IO (SuccessFlag, HscEnv)+    -> IO (SuccessFlag, [HomeModInfo]) upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do     (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan     runPipelines n_jobs hsc_env mHscMessage pipelines     res <- collect_result      let completed = [m | Just (Just m) <- res]-    let hsc_env' = addDepsToHscEnv completed hsc_env      -- Handle any cycle in the original compilation graph and return the result     -- of the upsweep.@@ -1244,10 +1240,10 @@         Just mss -> do           let logger = hsc_logger hsc_env           liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)-          return (Failed, hsc_env)+          return (Failed, [])         Nothing  -> do           let success_flag = successIf (all isJust res)-          return (success_flag, hsc_env')+          return (success_flag, completed)  toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])@@ -2310,18 +2306,21 @@           let action = logMsg logger msgClass srcSpan msg           case msgClass of             MCDiagnostic SevWarning _reason _code-              -> atomicModifyIORef' warnings $ \i -> (action: i, ())+              -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())             MCDiagnostic SevError _reason _code-              -> atomicModifyIORef' errors   $ \i -> (action: i, ())+              -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())             MCFatal-              -> atomicModifyIORef' fatals   $ \i -> (action: i, ())+              -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())             _ -> action          printDeferredDiagnostics = liftIO $           forM_ [warnings, errors, fatals] $ \ref -> do             -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content.-            actions <- atomicModifyIORef' ref $ \i -> ([], i)+            -- reset the content. The lazy variant is used here as we want to force+            -- this error if the IORef is ever accessed again, rather than now.+            -- See #20981 for an issue which discusses this general issue.+            let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []+            actions <- atomicModifyIORef ref $ \i -> (landmine, i)             sequence_ $ reverse actions      MC.bracket@@ -2397,8 +2396,9 @@  cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =-  unless (gopt Opt_KeepTmpFiles dflags) $-    liftIO $ cleanCurrentModuleTempFiles logger tmpfs+  if gopt Opt_KeepTmpFiles dflags+    then liftIO $ keepCurrentModuleTempFiles logger tmpfs+    else liftIO $ cleanCurrentModuleTempFiles logger tmpfs   addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv

@@ -129,6 +129,7 @@  import Data.Time        ( getCurrentTime ) import GHC.Iface.Recomp+import GHC.Types.Unique.DSet  -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m@@ -495,8 +496,18 @@          -- next, check libraries. XXX this only checks Haskell libraries,         -- not extra_libraries or -l things from the command line.+        -- pkg_deps is just the direct dependencies so take the transitive closure here+        -- to decide if we need to relink or not.+        let pkg_hslibs acc uid+              | uid `elementOfUniqDSet` acc = acc+              | Just c <- lookupUnitId unit_state uid =+                  foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c)+              | otherwise = acc++            all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps+         let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)-                          | Just c <- map (lookupUnitId unit_state) pkg_deps,+                          | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps),                             lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]          pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs@@ -846,18 +857,18 @@       else use (T_LlvmMangle pipe_env hsc_env llc_fn)   asPipeline False pipe_env hsc_env location mangled_fn -cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmCppPipeline pipe_env hsc_env input_fn = do   output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)   cmmPipeline pipe_env hsc_env output_fn -cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmPipeline pipe_env hsc_env input_fn = do   (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)   mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn   case mo_fn of-    Nothing -> panic "CMM pipeline - produced no .o file"-    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)+    Nothing -> return Nothing+    Just mo_fn -> Just <$> use (T_MergeForeign pipe_env hsc_env mo_fn fos)  jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath jsPipeline pipe_env hsc_env location input_fn = do@@ -935,8 +946,8 @@    fromPhase LlvmLlc    = llvmLlcPipeline pipe_env hsc_env Nothing input_fn    fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn    fromPhase StopLn     = return (Just input_fn)-   fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn-   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn+   fromPhase CmmCpp     = cmmCppPipeline pipe_env hsc_env input_fn+   fromPhase Cmm        = cmmPipeline pipe_env hsc_env input_fn    fromPhase Js         = Just <$> foreignJsPipeline pipe_env hsc_env Nothing input_fn    fromPhase MergeForeign = panic "fromPhase: MergeForeign" 

@@ -36,7 +36,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc-import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )+import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.HsToCore.Monad import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs@@ -783,16 +783,24 @@         -- Pattern match check warnings for /this match-group/.         -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.         -- Each Match will split off one Nablas for its RHSs from this.-        ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt+        ; matches_nablas <-+            if isMatchContextPmChecked dflags origin ctxt++            -- See Note [Long-distance information] in GHC.HsToCore.Pmc             then addHsScrutTmCs (concat scrs) new_vars $-                 -- See Note [Long-distance information]                  pmcMatches (DsMatchContext ctxt locn) new_vars matches-            else pure (initNablasMatches matches) +            -- When we're not doing PM checks on the match group,+            -- we still need to propagate long-distance information.+            -- See Note [Long-distance information in matchWrapper]+            else do { ldi_nablas <- getLdiNablas+                    ; pure $ initNablasMatches ldi_nablas matches }+         ; eqns_info   <- zipWithM mk_eqn_info matches matches_nablas -        ; result_expr <- handleWarnings $+        ; result_expr <- discard_warnings_if_generated origin $                          matchEquations ctxt new_vars eqns_info rhs_ty+         ; return (new_vars, result_expr) }   where     -- Called once per equation in the match, or alternative in the case@@ -810,19 +818,67 @@                             , eqn_orig = FromSource                             , eqn_rhs  = match_result } } -    handleWarnings = if isGenerated origin-                     then discardWarningsDs-                     else id+    discard_warnings_if_generated orig =+      if isGenerated orig+      then discardWarningsDs+      else id -    initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]-    initNablasMatches ms-      = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms+    initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]+    initNablasMatches ldi_nablas ms+      = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms -    initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas-    initNablasGRHSs m = expectJust "GRHSs non-empty"-                      $ NEL.nonEmpty-                      $ replicate (length (grhssGRHSs m)) initNablas+    initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas+    initNablasGRHSs ldi_nablas m+      = expectJust "GRHSs non-empty"+      $ NEL.nonEmpty+      $ replicate (length (grhssGRHSs m)) ldi_nablas +{- Note [Long-distance information in matchWrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checking in matchWrapper is done conditionally, depending+on isMatchContextPmChecked. This means that we don't perform pattern match+checking on e.g. generated pattern matches.++However, when we skip pattern match checking, we still need to keep track+of long-distance information in case we need it in a nested context.++This came up in #23445. For example:++  data GADT a where+    IsUnit :: GADT ()++  data Foo b where+    FooUnit :: Foo ()+    FooInt  :: Foo Int++  data SomeRec = SomeRec { fld :: () }++  bug :: GADT a -> Foo a -> SomeRec -> SomeRec+  bug IsUnit foo r =+    let gen_fld :: ()+        gen_fld = case foo of { FooUnit -> () }+    in case r of { SomeRec _ -> SomeRec gen_fld }++Here the body of 'bug' was generated by 'desugarRecordUpd' from the user-written+record update++  cd { fld = case foo of { FooUnit -> () } }++As a result, we have a generated FunBind gen_fld whose RHS++  case foo of { FooUnit -> () }++is user-written. This all happens after the GADT pattern match on IsUnit,+which brings into scope the Given equality [G] a ~ (). We need to make sure+that this long distance information is visible when pattern match checking the+user-written case statement.++To propagate this long-distance information in 'matchWrapper', when we skip+pattern match checks, we make sure to manually pass the long-distance+information to 'mk_eqn_info', which is responsible for recurring further into+the expression (in this case, it will end up recursively calling 'matchWrapper'+on the user-written case statement).+-}  matchEquations  :: HsMatchContext GhcRn                 -> [MatchId] -> [EquationInfo] -> Type

@@ -39,7 +39,7 @@         isMatchContextPmChecked,          -- See Note [Long-distance information]-        addTyCs, addCoreScrutTmCs, addHsScrutTmCs+        addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas     ) where  import GHC.Prelude@@ -142,8 +142,8 @@ -- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.) -- each of a 'Match'es 'GRHS' for Note [Long-distance information]. ----- Special case: When there are /no matches/, then the functionassumes it--- checks and @-XEmptyCase@ with only a single match variable.+-- Special case: When there are /no matches/, then the function assumes it+-- checks an @-XEmptyCase@ with only a single match variable. -- See Note [Checking EmptyCase]. pmcMatches   :: DsMatchContext                  -- ^ Match context, for warnings messages

@@ -67,7 +67,10 @@         ticky =           map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] -        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))+        -- Other flags which affect code generation+        codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags)++        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))      in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags

@@ -126,7 +126,7 @@       if gopt Opt_SingleLibFolder dflags       then do         libs <- getLibs namever ways_ unit_env dep_units-        tmpDir <- newTempDir logger tmpfs (tmpDir dflags)+        tmpDir <- newTempSubDir logger tmpfs (tmpDir dflags)         sequence_ [ copyFile lib (tmpDir </> basename)                   | (lib, basename) <- libs]         return [ "-L" ++ tmpDir ]

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

@@ -37,6 +37,7 @@ import GHC.Core.Type  import GHC.StgToCmm.Types+import GHC.StgToCmm.Closure (mkLFImported)  import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn@@ -272,13 +273,10 @@                             TagTagged -> True                             TagTuple _ -> True -- Consider unboxed tuples tagged.         False -- Imported-            | Just con <- (isDataConWorkId_maybe v)-            , isNullaryRepDataCon con-            -> return True-            | Just lf_info <- idLFInfo_maybe v             -> return $!-                -- Can we treat the thing as tagged based on it's LFInfo?-                case lf_info of+                -- Determine whether it is tagged from the LFInfo of the imported id.+                -- See Note [The LFInfo of Imported Ids]+                case mkLFImported v of                     -- Function, applied not entered.                     LFReEntrant {}                         -> True@@ -296,10 +294,7 @@                     -- Shouldn't be possible. I don't think we can export letNoEscapes                         -> True -            | otherwise-            -> return False - isArgTagged :: StgArg -> RM Bool isArgTagged (StgLitArg _) = return True isArgTagged (StgVarArg v) = isTagged v@@ -374,7 +369,9 @@             fvs <- fvArgs args             -- lcls <- getFVs             -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)-            return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)+            -- We mark the closure updatable to retain sharing in the case that+            -- conExpr is an infinite recursive data type. See #23783.+            return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do     withBinders NotTopLevel args $         withClosureLcls fvs $

@@ -175,10 +175,35 @@     lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind     lint_bind (StgTopStringLit v _) = return [v] -lintStgArg :: StgArg -> LintM ()-lintStgArg (StgLitArg _) = return ()-lintStgArg (StgVarArg v) = lintStgVar v+lintStgConArg :: StgArg -> LintM ()+lintStgConArg arg = do+  unarised <- lf_unarised <$> getLintFlags+  when unarised $ case typePrimRep_maybe (stgArgType arg) of+    -- Note [Post-unarisation invariants], invariant 4+    Just [_] -> pure ()+    badRep   -> addErrL $+      text "Non-unary constructor arg: " <> ppr arg $$+      text "Its PrimReps are: " <> ppr badRep +  case arg of+    StgLitArg _ -> pure ()+    StgVarArg v -> lintStgVar v++lintStgFunArg :: StgArg -> LintM ()+lintStgFunArg arg = do+  unarised <- lf_unarised <$> getLintFlags+  when unarised $ case typePrimRep_maybe (stgArgType arg) of+    -- Note [Post-unarisation invariants], invariant 3+    Just []  -> pure ()+    Just [_] -> pure ()+    badRep   -> addErrL $+      text "Function arg is not unary or void: " <> ppr arg $$+      text "Its PrimReps are: " <> ppr badRep++  case arg of+    StgLitArg _ -> pure ()+    StgVarArg v -> lintStgVar v+ lintStgVar :: Id -> LintM () lintStgVar id = checkInScope id @@ -248,16 +273,13 @@      lintConApp con args (pprStgRhs opts rhs) -    mapM_ lintStgArg args-    mapM_ checkPostUnariseConArg args- lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()  lintStgExpr (StgLit _) = return ()  lintStgExpr e@(StgApp fun args) = do   lintStgVar fun-  mapM_ lintStgArg args+  mapM_ lintStgFunArg args   lintAppCbvMarks e   lintStgAppReps fun args @@ -275,11 +297,8 @@     opts <- getStgPprOpts     lintConApp con args (pprStgExpr opts app) -    mapM_ lintStgArg args-    mapM_ checkPostUnariseConArg args- lintStgExpr (StgOpApp _ args _) =-    mapM_ lintStgArg args+    mapM_ lintStgFunArg args  lintStgExpr (StgLet _ binds body) = do     binders <- lintStgBinds NotTopLevel binds@@ -322,12 +341,14 @@     mapM_ checkPostUnariseBndr bndrs     addInScopeVars bndrs (lintStgExpr rhs) --- Post unarise check we apply constructors to the right number of args.--- This can be violated by invalid use of unsafeCoerce as showcased by test--- T9208-lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()+lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM () lintConApp con args app = do+    mapM_ lintStgConArg args     unarised <- lf_unarised <$> getLintFlags++    -- Post unarise check we apply constructors to the right number of args.+    -- This can be violated by invalid use of unsafeCoerce as showcased by test+    -- T9208; see also #23865     when (unarised &&           not (isUnboxedTupleDataCon con) &&           length (dataConRuntimeRepStrictness con) /= length args) $ do@@ -361,6 +382,8 @@         = match_args actual_reps_left expected_reps_left          -- Check for void rep which can be either an empty list *or* [VoidRep]+           -- No, typePrimRep_maybe will never return a result containing VoidRep.+           -- We should refactor to make this obvious from the types.         | isVoidRep actual_rep && isVoidRep expected_rep         = match_args actual_reps_left expected_reps_left @@ -506,20 +529,6 @@           text "After unarisation, binder " <>           ppr bndr <> text " has " <> text unexpected <> text " type " <>           ppr (idType bndr)---- Arguments shouldn't have sum, tuple, or void types.-checkPostUnariseConArg :: StgArg -> LintM ()-checkPostUnariseConArg arg = case arg of-    StgLitArg _ ->-      return ()-    StgVarArg id -> do-      lf <- getLintFlags-      when (lf_unarised lf) $-        forM_ (checkPostUnariseId id) $ \unexpected ->-          addErrL $-            text "After unarisation, arg " <>-            ppr id <> text " has " <> text unexpected <> text " type " <>-            ppr (idType id)  -- Post-unarisation args and case alt binders should not have unboxed tuple, -- unboxed sum, or void types. Return what the binder is if it is one of these.

@@ -356,20 +356,17 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ STG programs after unarisation have these invariants: -  * No unboxed sums at all.+ 1. No unboxed sums at all. -  * No unboxed tuple binders. Tuples only appear in return position.+ 2. No unboxed tuple binders. Tuples only appear in return position. -  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.+ 3. Binders and literals always have zero (for void arguments) or one PrimRep.++ 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments.     This means that it's safe to wrap `StgArg`s of DataCon applications with     `GHC.StgToCmm.Env.NonVoid`, for example. -  * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only-    appear in return position.--  * Alt binders (binders in patterns) are always non-void.--  * Binders always have zero (for void arguments) or one PrimRep.+ 5. Alt binders (binders in patterns) are always non-void. -}  module GHC.Stg.Unarise (unarise) where@@ -555,7 +552,7 @@    -- See (3) of Note [Rubbish literals] in GHC.Types.Literal   | StgLit lit <- scrut-  , Just args' <- unariseRubbish_maybe lit+  , Just args' <- unariseLiteral_maybe lit   = elimCase rho args' bndr alt_ty alts    -- general case@@ -592,20 +589,24 @@   | otherwise   = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple" --- Doesn't return void args.-unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]-unariseRubbish_maybe (LitRubbish torc rep)+-- Returns @Nothing@ if the given literal is already unary (exactly+-- one PrimRep).  Doesn't return void args.+--+-- This needs to exist because rubbish literals can have any representation.+-- See also Note [Rubbish literals] in GHC.Types.Literal.+unariseLiteral_maybe :: Literal -> Maybe [OutStgArg]+unariseLiteral_maybe (LitRubbish torc rep)   | [prep] <- preps-  , not (isVoidRep prep)+  , assert (not (isVoidRep prep)) True   = Nothing   -- Single, non-void PrimRep. Nothing to do!    | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase   = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep))-         | prep <- preps, not (isVoidRep prep) ]+         | prep <- preps, assert (not (isVoidRep prep)) True ]   where-    preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep+    preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep -unariseRubbish_maybe _ = Nothing+unariseLiteral_maybe _ = Nothing  -------------------------------------------------------------------------------- @@ -956,6 +957,8 @@ --------------------------------------------------------------------------------  {-+Note [Unarisation of Void binders and arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For arguments (StgArg) and binders (Id) we have two kind of unarisation:    - When unarising function arg binders and arguments, we don't want to remove@@ -1050,7 +1053,11 @@     Just (MultiVal as)  -> as     Just (UnaryVal arg) -> [arg]     Nothing             -> [StgVarArg x]-unariseFunArg _ arg = [arg]+unariseFunArg _ arg@(StgLitArg lit) = case unariseLiteral_maybe lit of+  -- forgetting to unariseLiteral_maybe here caused #23914+  Just [] -> [voidArg]+  Just as -> as+  Nothing -> [arg]  unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] unariseFunArgs = concatMap . unariseFunArg@@ -1076,7 +1083,7 @@                                      -- is a void, and so should be eliminated       | otherwise -> [StgVarArg x] unariseConArg _ arg@(StgLitArg lit)-  | Just as <- unariseRubbish_maybe lit+  | Just as <- unariseLiteral_maybe lit   = as   | otherwise   = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals

@@ -264,21 +264,123 @@         -- Use the LambdaFormInfo from the interface         lf_info       Nothing-        -- Interface doesn't have a LambdaFormInfo, make a conservative one from-        -- the type.-        | Just con <- isDataConWorkId_maybe id-        , isNullaryRepDataCon con-        -> LFCon con   -- An imported nullary constructor-                       -- We assume that the constructor is evaluated so that-                       -- the id really does point directly to the constructor-+        -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type.+        -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed!         | arity > 0         -> LFReEntrant TopLevel arity True ArgUnknown +        | Just con <- isDataConId_maybe id+          -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types+          -- and Note [The LFInfo of Imported Ids] below+        -> assert (hasNoNonZeroWidthArgs con) $+           LFCon con   -- An imported nullary constructor+                       -- We assume that the constructor is evaluated so that+                       -- the id really does point directly to the constructor+         | otherwise         -> mkLFArgument id -- Not sure of exact arity   where     arity = idFunRepArity id+    hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys++{-+Note [The LFInfo of Imported Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Conveying CAF-info and LFInfo between modules] and+Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the+LambdaFormInfo records the details of a closure representation and is often,+when optimisations are enabled, serialized to the interface of a module.++In particular, the `lfInfo` field of the `IdInfo` field of an `Id`+* For Ids defined in this module: is `Nothing`+* For imported Ids:+  * is (Just lf_info) if the LFInfo was serialised into the interface file+    (typically, when the exporting module was compiled with -O)+  * is Nothing if it wasn't serialised++However, when an interface doesn't have a LambdaFormInfo for some imported Id+(so that its `lfInfo` field is `Nothing`), we can conservatively create one+using `mkLFImported`.++The LambdaFormInfo we give an Id is used in determining how to tag its pointer+(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as+faithfully as possible or otherwise risk having pointers incorrectly tagged,+which can lead to performance issues and even segmentation faults (see #23231+and #23146). In particular, saturated data constructor applications *must* be+unambiguously given `LFCon`, and the invariant++  If the LFInfo (serialised or built with mkLFImported) says LFCon, then it+  really is a static data constructor, and similar for LFReEntrant++must be upheld.++In `mkLFImported`, we make a conservative approximation to the real+LambdaFormInfo as follows:++(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are+tagged (by `litIdInfo`) with the corresponding arity.+    - This is also true of data con wrappers and workers with arity > 0,+    regardless of the runtime relevance of the arguments+    - For example, `Just :: a -> Maybe a` is given `LFReEntrant`+               and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too++(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because+they are fully saturated data constructor applications and pointers to them+should be tagged with the constructor index.++(2.1) A datacon *wrapper* with zero arity must be a fully saturated application+of the worker to zero-width arguments only (which are dropped after unarisation)++(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes+no arguments whatsoever (not even zero-width args)++To ensure we properly give `LFReEntrant` to data constructors with some arity,+and `LFCon` only to data constructors with zero arity, we must first check for+`arity > 0` and only afterwards `isDataConId` -- the order of the guards in+`mkLFImported` is quite important.++As an example, consider the following data constructors:++  data T1 a where+    TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a++  data T2 a where+    TCon2 :: {-# UNPACK #-} !() -> T2 a++  data T3 a where+    TCon3 :: T3 '[]++`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while+the worker has an unlifted equality argument, which is zero-width.++`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width,+while the worker has no arguments.++`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument;+their Core representation:++  $WTCon3 :: T3 '[]+  $WTCon3 = TCon3 @[] <Refl>++  TCon3 :: forall (a :: * -> *). (a ~# []) => T a+  TCon3 = /\a. \(co :: a~#[]). TCon3 co++For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they+both have arity == 1.++For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1+while the worker is `LFCon` since its arity == 0++For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the+worker `LFReEntrant` since its arity == 1++One might think we could give *workers* with only zero-width-args the `LFCon`+LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`.+However, these workers, albeit rarely used, are unambiguously functions+-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct.+See also the discussion in #23158.++-}  ------------- mkLFStringLit :: LambdaFormInfo

@@ -83,8 +83,8 @@ mkRhsInit platform reg lf_info expr   = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) +-- | Returns a 'CmmExpr' for the *tagged* pointer idInfoToAmode :: CgIdInfo -> CmmExpr--- Returns a CmmExpr for the *tagged* pointer idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc@@ -151,7 +151,7 @@               in return $                   litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)           else-              cgLookupPanic id -- Bug+              cgLookupPanic id -- Bug, id is neither in local binds nor is external         }}}  -- | Retrieve cg info for a name if it already exists.

@@ -8,7 +8,9 @@  module GHC.StgToCmm.Foreign (   cgForeignCall,-  emitPrimCall, emitCCall,+  emitPrimCall,+  emitCCall,+  emitCCallNeverReturns,   emitForeignCall,   emitSaveThreadState,   saveThreadState,@@ -194,17 +196,31 @@ -}  -emitCCall :: [(CmmFormal,ForeignHint)]-          -> CmmExpr-          -> [(CmmActual,ForeignHint)]-          -> FCode ()-emitCCall hinted_results fn hinted_args+emitCCall' :: CmmReturnInfo+           -> [(CmmFormal,ForeignHint)]+           -> CmmExpr+           -> [(CmmActual,ForeignHint)]+           -> FCode ()+emitCCall' ret_info hinted_results fn hinted_args   = void $ emitForeignCall PlayRisky results target args   where     (args, arg_hints) = unzip hinted_args     (results, result_hints) = unzip hinted_results     target = ForeignTarget fn fc-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+    fc = ForeignConvention CCallConv arg_hints result_hints ret_info++emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall = emitCCall' CmmMayReturn++emitCCallNeverReturns+  :: [(CmmFormal,ForeignHint)]+  -> CmmExpr+  -> [(CmmActual,ForeignHint)]+  -> FCode ()+emitCCallNeverReturns = emitCCall' CmmNeverReturns   emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()

@@ -188,9 +188,11 @@  data CgIdInfo   = CgIdInfo-        { cg_id :: Id   -- Id that this is the info for+        { cg_id  :: Id+          -- ^ Id that this is the info for         , cg_lf  :: LambdaFormInfo-        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        , cg_loc :: CgLoc+          -- ^ 'CmmExpr' for the *tagged* value         }  instance OutputableP Platform CgIdInfo where

@@ -311,7 +311,7 @@ --  #define sizzeofByteArrayzh(r,a) \ --     r = ((StgArrBytes *)(a))->bytes   SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)  --  #define sizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes@@ -320,7 +320,7 @@ --  #define getSizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes   GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)   --  #define touchzh(o)                  /* nothing */@@ -394,15 +394,10 @@ -- Getting the size of pointer arrays    SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg-      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))-        (bWord platform))+    emitAssign (CmmLocal res) (ptrArraySize platform profile arg)   SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp   SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ mkAssign (CmmLocal res)-     (cmmLoadIndexW platform arg-     (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))-        (bWord platform))+    emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg)    SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp   GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp@@ -2040,7 +2035,7 @@                  -> [CmmExpr]                  -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx+   = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2052,7 +2047,7 @@                    -> FCode () doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]    = let alignment = alignmentFromTypes rep idx_rep-     in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx+     in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2064,7 +2059,7 @@ doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]    = do profile <- getProfile         doByteArrayBoundsCheck idx addr rep rep-        mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+        mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2078,7 +2073,7 @@    = do profile <- getProfile         doByteArrayBoundsCheck idx addr idx_rep rep         let alignment = alignmentFromTypes rep idx_rep-        mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+        mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2090,15 +2085,15 @@    = do profile <- getProfile         platform <- getPlatform         doPtrArrayBoundsCheck idx addr-        mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx+        mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx  doWriteOffAddrOp :: Maybe MachOp                  -> CmmType                  -> [LocalReg]                  -> [CmmExpr]                  -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp castOp idx_ty [] [addr,idx, val]+   = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val) doWriteOffAddrOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" @@ -2107,11 +2102,12 @@                    -> [LocalReg]                    -> [CmmExpr]                    -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal]    = do profile <- getProfile         platform <- getPlatform+        let val = maybeCast castOp rawVal         doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)-        mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val+        mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val doWriteByteArrayOp _ _ _ _    = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2133,8 +2129,7 @@        -- This write barrier is to ensure that the heap writes to the object        -- referred to by val have happened before we write val into the array.        -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val+       mkBasicIndexedWrite True hdr_size addr ty idx val         emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))        -- the write barrier.  We must write a byte into the mark table:@@ -2142,16 +2137,12 @@        emit $ mkStore (          cmmOffsetExpr platform           (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)-                         (loadArrPtrsSize profile addr))+                         (ptrArraySize platform profile addr))           (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])          ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr-loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off)- where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)-       platform = profilePlatform profile--mkBasicIndexedRead :: AlignmentSpec+mkBasicIndexedRead :: Bool         -- Should this imply an acquire barrier+                   -> AlignmentSpec                    -> ByteOff      -- Initial offset in bytes                    -> Maybe MachOp -- Optional result cast                    -> CmmType      -- Type of element we are accessing@@ -2160,27 +2151,40 @@                    -> CmmType      -- Type of element by which we are indexing                    -> CmmExpr      -- Index                    -> FCode ()-mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx-   = do platform <- getPlatform-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)-mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx+mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx    = do platform <- getPlatform-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])+        let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        result <-+          if barrier+          then do+            res <- newTemp ty+            emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr]+            return $ CmmReg (CmmLocal res)+          else+            return $ CmmLoad addr ty alignment -mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast+        let casted =+              case mb_cast of+                Just cast -> CmmMachOp cast [result]+                Nothing   -> result+        emitAssign (CmmLocal res) casted++mkBasicIndexedWrite :: Bool         -- Should this imply a release barrier+                    -> ByteOff      -- Initial offset in bytes                     -> CmmExpr      -- Base address                     -> CmmType      -- Type of element by which we are indexing                     -> CmmExpr      -- Index                     -> CmmExpr      -- Value to write                     -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val+mkBasicIndexedWrite barrier off base idx_ty idx val    = do platform <- getPlatform         let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty-        emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])+            addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        if barrier+          then let w = typeWidth idx_ty+                   op = MO_AtomicWrite w MemOrderRelease+               in emitPrimCall [] op [addr, val]+          else emitStore' alignment addr val  -- ---------------------------------------------------------------------------- -- Misc utils@@ -2208,6 +2212,30 @@ setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr+maybeCast Nothing val = val+maybeCast (Just cast) val = CmmMachOp cast [val]++ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+ptrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)++smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+smallPtrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)++byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+byteArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)+++ ------------------------------------------------------------------------------ -- Helpers for translating vector primops. @@ -2453,10 +2481,9 @@     profile <- getProfile     platform <- getPlatform -    ifNonZero n $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)-        doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8-        doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8+    whenCheckBounds $ ifNonZero n $ do+        emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1)+        emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2)      ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off     ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off@@ -2519,7 +2546,7 @@     -- Copy data (we assume the arrays aren't overlapping since     -- they're of different types)     copy _src _dst dst_p src_p bytes align =-        emitMemcpyCall dst_p src_p bytes align+        emitCheckedMemcpyCall dst_p src_p bytes align  -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the@@ -2548,10 +2575,9 @@     profile <- getProfile     platform <- getPlatform -    ifNonZero n $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+    whenCheckBounds $ ifNonZero n $ do+        emitRangeBoundsCheck src_off n (byteArraySize platform profile src)+        emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst)      let byteArrayAlignment = wordAlignment platform         srcOffAlignment = cmmExprAlignment src_off@@ -2569,11 +2595,10 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     profile <- getProfile     platform <- getPlatform-    ifNonZero bytes $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8+    whenCheckBounds $ ifNonZero bytes $ do+        emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src)     src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+    emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1)  -- | Takes a source 'MutableByteArray#', an offset in the source array, a -- destination 'Addr#', and the number of bytes to copy.  Copies the given@@ -2590,19 +2615,21 @@     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     profile <- getProfile     platform <- getPlatform-    ifNonZero bytes $ do-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+    whenCheckBounds $ ifNonZero bytes $ do+        emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst)     dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+    emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1)  ifNonZero :: CmmExpr -> FCode () -> FCode () ifNonZero e it = do     platform <- getPlatform     let pred = cmmNeWord platform e (zeroExpr platform)     code <- getCode it-    emit =<< mkCmmIfThen' pred code (Just False)+    emit =<< mkCmmIfThen' pred code (Just True)+      -- This function is used for range operation bounds-checks;+      -- Most calls to those ops will not have range length zero. + -- ---------------------------------------------------------------------------- -- Setting byte arrays @@ -2615,8 +2642,8 @@     profile <- getProfile     platform <- getPlatform -    doByteArrayBoundsCheck off ba b8 b8-    doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8+    whenCheckBounds $ ifNonZero len $+      emitRangeBoundsCheck off len (byteArraySize platform profile ba)      let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap         offsetAlignment = cmmExprAlignment off@@ -2687,7 +2714,7 @@     -- they're of different types)     copy _src _dst dst_p src_p bytes =         do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)                (wordAlignment platform)  @@ -2729,8 +2756,11 @@         dst     <- assignTempE dst0         dst_off <- assignTempE dst_off0 -        doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src-        doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+        whenCheckBounds $ do+          emitRangeBoundsCheck src_off (mkIntExpr platform n)+                                       (ptrArraySize platform profile src)+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)+                                       (ptrArraySize platform profile dst)          -- Nonmoving collector write barrier         emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n@@ -2749,7 +2779,7 @@          -- The base address of the destination card table         dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p-                       (loadArrPtrsSize profile dst)+                       (ptrArraySize platform profile dst)          emitSetCards dst_off dst_cards_p n @@ -2761,7 +2791,7 @@     -- they're of different types)     copy _src _dst dst_p src_p bytes =         do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)                (wordAlignment platform)  @@ -2798,9 +2828,11 @@         src     <- assignTempE src0         dst     <- assignTempE dst0 -        when (n /= 0) $ do-            doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src-            doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+        whenCheckBounds $ do+          emitRangeBoundsCheck src_off (mkIntExpr platform n)+                                       (smallPtrArraySize platform profile src)+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)+                                       (smallPtrArraySize platform profile dst)          -- Nonmoving collector write barrier         emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n@@ -2895,7 +2927,7 @@      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) --- | Takes and offset in the destination array, the base address of+-- | Takes an offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). The number of elements may not be zero. -- Marks the relevant cards as dirty.@@ -2928,7 +2960,7 @@     profile <- getProfile     platform <- getPlatform     doSmallPtrArrayBoundsCheck idx addr-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr+    mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr         (gcWord platform) idx  doWriteSmallPtrArrayOp :: CmmExpr@@ -2944,11 +2976,11 @@      -- Update remembered set for non-moving collector     tmp <- newTemp ty-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx+    mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx     whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) -    emitPrimCall [] MO_WriteBarrier [] -- #12469-    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val+    -- Write barrier needed due to #12469+    mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val     emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))  ------------------------------------------------------------------------------@@ -3074,6 +3106,26 @@         (MO_Memcpy (alignmentBytes align))         [ dst, src, n ] +-- | Emit a call to @memcpy@, but check for range+-- overlap when -fcheck-prim-bounds is on.+emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitCheckedMemcpyCall dst src n align = do+    whenCheckBounds (getPlatform >>= doCheck)+    emitMemcpyCall dst src n align+  where+    doCheck platform = do+        overlapCheckFailed <- getCode $+          emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) []+        emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False)+      where+        rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero+        checkDiff p q = (p `minus` q) `uLT` n+        or = cmmOrWord platform+        minus = cmmSubWord platform+        uLT  = cmmULtWord platform+        ne   = cmmNeWord platform+        zero = zeroExpr platform+ -- | Emit a call to @memmove@. emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () emitMemmoveCall dst src n align =@@ -3168,50 +3220,68 @@ -- Array bounds checking --------------------------------------------------------------------------- -doBoundsCheck :: CmmExpr  -- ^ accessed index-              -> CmmExpr  -- ^ array size (in elements)-              -> FCode ()-doBoundsCheck idx sz = do-    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig-    platform        <- getPlatform-    when do_bounds_check (doCheck platform)-  where-    doCheck platform = do-        boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []-        emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)-      where-        uGE = cmmUGeWord platform-        and = cmmAndWord platform-        zero = zeroExpr platform-        ne  = cmmNeWord platform-        isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero+whenCheckBounds :: FCode () -> FCode ()+whenCheckBounds a = do+  config <- getStgToCmmConfig+  case stgToCmmDoBoundsCheck config of+    False -> pure ()+    True  -> a --- We want to make sure that the array size computation is pushed into the--- Opt_DoBoundsChecking check to avoid regregressing compiler performance when--- it's disabled.-{-# INLINE doBoundsCheck #-}+emitBoundsCheck :: CmmExpr  -- ^ accessed index+                -> CmmExpr  -- ^ array size (in elements)+                -> FCode ()+emitBoundsCheck idx sz = do+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)+    platform <- getPlatform+    boundsCheckFailed <- getCode $+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []+    let isOutOfBounds = cmmUGeWord platform idx sz+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) +emitRangeBoundsCheck :: CmmExpr  -- ^ first accessed index+                     -> CmmExpr  -- ^ number of accessed indices (non-zero)+                     -> CmmExpr  -- ^ array size (in elements)+                     -> FCode ()+emitRangeBoundsCheck idx len arrSizeExpr = do+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)+    config <- getStgToCmmConfig+    platform <- getPlatform+    arrSize <- assignTempE arrSizeExpr+    -- arrSizeExpr is probably a load we don't want to duplicate+    rangeTooLargeReg <- newTemp (bWord platform)+    lastSafeIndexReg <- newTemp (bWord platform)+    _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $+      cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing+    boundsCheckFailed <- getCode $+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []+    let+      rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg)+      lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg)+      badStartIndex = (idx `uGT` lastSafeIndex)+      isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero+      uGT = cmmUGtWord platform+      or = cmmOrWord platform+      neq = cmmNeWord platform+      zero = zeroExpr platform+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)+ doPtrArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in bytes)     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@     -> FCode ()-doPtrArrayBoundsCheck idx arr = do+doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)-    doBoundsCheck idx sz+    emitBoundsCheck idx (ptrArraySize platform profile arr)  doSmallPtrArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in bytes)     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@     -> FCode ()-doSmallPtrArrayBoundsCheck idx arr = do+doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)-    doBoundsCheck idx sz+    emitBoundsCheck idx (smallPtrArraySize platform profile arr)  doByteArrayBoundsCheck     :: CmmExpr  -- ^ accessed index (in elements)@@ -3219,18 +3289,18 @@     -> CmmType  -- ^ indexing type     -> CmmType  -- ^ element type     -> FCode ()-doByteArrayBoundsCheck idx arr idx_ty elem_ty = do+doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do     profile <- getProfile     platform <- getPlatform-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)-        sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)-        elem_sz = widthInBytes $ typeWidth elem_ty-        idx_sz = widthInBytes $ typeWidth idx_ty-        -- Ensure that the last byte of the access is within the array-        idx_bytes = cmmOffsetB platform-          (cmmMulWord platform idx (mkIntExpr platform idx_sz))-          (elem_sz - 1)-    doBoundsCheck idx_bytes sz+    let elem_w = typeWidth elem_ty+        idx_w = typeWidth idx_ty+        elem_sz = mkIntExpr platform $ widthInBytes elem_w+        arr_sz = byteArraySize platform profile arr+        effective_arr_sz =+          cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w))+    if elem_w == idx_w+      then emitBoundsCheck idx effective_arr_sz  -- aligned => simpler check+      else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz)  --------------------------------------------------------------------------- -- Pushing to the update remembered set

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

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

@@ -354,8 +354,9 @@                -- Do /not/ use the tidied tvs because then are in the                -- wrong order, so tidying will rename things wrongly        ; reportWanteds ctxt' tc_lvl wanted-       ; when (cec_warn_redundant ctxt) $-         warnRedundantConstraints ctxt' tcl_env info' dead_givens }++       -- Report redundant (unused) constraints+       ; warnRedundantConstraints ctxt' tcl_env info' dead_givens }   where     insoluble    = isInsolubleStatus status     (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $@@ -392,9 +393,19 @@ warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver warnRedundantConstraints ctxt env info redundant_evs+ | not (cec_warn_redundant ctxt)+ = return ()+  | null redundant_evs  = return () + -- Do not report redundant constraints for quantified constraints+ -- See (RC4) in Note [Tracking redundant constraints]+ -- Fortunately it is easy to spot implications constraints that arise+ -- from quantified constraints, from their SkolInfo+ | InstSkol (IsQC {}) _ <- info+ = return ()+  | SigSkol user_ctxt _ _ <- info  -- When dealing with a user-written type signature,  -- we want to add "In the type signature for f".@@ -478,30 +489,37 @@                             , ei_m_reason = m_reason                             , ei_suppress = suppress }} +-- | Actually report this 'ErrorItem'.+unsuppressErrorItem :: ErrorItem -> ErrorItem+unsuppressErrorItem ei = ei { ei_suppress = False }+ ---------------------------------------------------------------- reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics                                  , wc_errors = errs })   | isEmptyWC wc = traceTc "reportWanteds empty WC" empty   | otherwise-  = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts+  = do { tidy_items1 <- mapMaybeM mkErrorItem tidy_cts        ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples                                          , text "Suppress =" <+> ppr (cec_suppress ctxt)                                          , text "tidy_cts   =" <+> ppr tidy_cts-                                         , text "tidy_items =" <+> ppr tidy_items+                                         , text "tidy_items1 =" <+> ppr tidy_items1                                          , text "tidy_errs =" <+> ppr tidy_errs ]) -       -- This check makes sure that we aren't suppressing the only error that will-       -- actually stop compilation-       ; assertPprM-           ( do { errs_already <- ifErrsM (return True) (return False)-                ; return $-                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)-                    null simples ||                  -- no errors to report here-                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)-                    not (all ei_suppress tidy_items) -- not all errors are suppressed-                } )-           (vcat [text "reportWanteds is suppressing all errors"])+         -- Catch an awkward case in which /all/ errors are suppressed:+         -- see Wrinkle at end of Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+         -- Unless we are sure that an error will be reported some other way (details+         -- in the defn of tidy_items) un-suppress the lot. This makes sure we don't forget to+         -- report an error at all, which is catastrophic: GHC proceeds to desguar and optimise+         -- the program, even though it is full of type errors (#22702, #22793)+       ; errs_already <- ifErrsM (return True) (return False)+       ; let tidy_items+               | not errs_already                     -- Have not already reported an error (perhaps+                                                      --   from an outer implication); see #21405+               , not (any ignoreConstraint simples)   -- No error is ignorable (is reported elsewhere)+               , all ei_suppress tidy_items1          -- All errors are suppressed+                           = map unsuppressErrorItem tidy_items1+               | otherwise = tidy_items1           -- First, deal with any out-of-scope errors:        ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs@@ -1424,16 +1442,19 @@                 -- the valid hole fits. validHoleFits ctxt@(CEC { cec_encl = implics                         , cec_tidy = lcl_env}) simps hole-  = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole+  = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (mapMaybe mk_wanted simps) hole        ; return (ctxt {cec_tidy = tidy_env}, fits) }   where-    mk_wanted :: ErrorItem -> CtEvidence-    mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })-         = CtWanted { ctev_pred      = pred-                    , ctev_dest      = dest-                    , ctev_loc       = loc-                    , ctev_rewriters = emptyRewriterSet }-    mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)+    mk_wanted :: ErrorItem -> Maybe CtEvidence+    mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc })+      | Just dest <- m_dest+      = Just (CtWanted { ctev_pred      = pred+                       , ctev_dest      = dest+                       , ctev_loc       = loc+                       , ctev_rewriters = emptyRewriterSet })+      | otherwise+      = Nothing   -- The ErrorItem was a Given+  -- See Note [Constraints include ...] givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]

@@ -1176,6 +1176,22 @@                                 or multi-parameter type classes  - an inferred type that includes unboxed tuples +Note [Inferred type with escaping kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check for an inferred type with an escaping kind; e.g. #23051+   forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a+where the kind of the body of the forall mentions `f` and `g` which+are bound by the forall.  No no no.++This check, mkInferredPolyId, is really in the wrong place:+`inferred_poly_ty` doesn't obey the PKTI and it would be better not to+generalise it in the first place; see #20686.  But for now it works.++I considered adjusting the generalisation in GHC.Tc.Solver to directly check for+escaping kind variables; instead, promoting or defaulting them. But that+gets into the defaulting swamp and is a non-trivial and unforced+change, so I have left it alone for now.+ Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1265,7 +1281,9 @@   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $     do  { ((co_fn, matches'), rhs_ty')-            <- tcInfer $ \ exp_ty ->+            <- tcInferFRR (FRRBinder name) $ \ exp_ty ->+                          -- tcInferFRR: the type of a let-binder must have+                          -- a fixed runtime rep. See #23176                        tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $                           -- We extend the error context even for a non-recursive                           -- function so that in type error messages we show the@@ -1287,7 +1305,9 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , all (isNothing . sig_fn) bndrs   = addErrCtxt (patMonoBindsCtxt pat grhss) $-    do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->+    do { (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->+                          -- tcInferFRR: the type of each let-binder must have+                          -- a fixed runtime rep. See #23176                              tcGRHSsPat grhss exp_ty         ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR

@@ -405,9 +405,34 @@        ; tcEmitBindingUsage (supUE u1 u2)        ; return (HsIf x pred' b1' b2') } +{-+Note [MultiWayIf linearity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we'd like to compute the usage environment for++if | b1 -> e1+   | b2 -> e2+   | otherwise -> e3++and let u1, u2, v1, v2, v3 denote the usage env for b1, b2, e1, e2, e3+respectively.++Since a multi-way if is mere sugar for nested if expressions, the usage+environment should ideally be u1 + sup(v1, u2 + sup(v2, v3)).+However, currently we don't support linear guards (#19193). All variables+used in guards from u1 and u2 will have multiplicity Many.+But in that case, we have equality u1 + sup(x,y) = sup(u1 + x, y),+                      and likewise u2 + sup(x,y) = sup(u2 + x, y) for any x,y.+Using this identity, we can just compute sup(u1 + v1, u2 + v2, v3) instead.+This is simple to do, since we get u_i + v_i directly from tcGRHS.+If we add linear guards, this code will have to be revisited.+Not using 'sup' caused #23814.+-}+ tcExpr (HsMultiIf _ alts) res_ty-  = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts+  = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts        ; res_ty <- readExpType res_ty+       ; tcEmitBindingUsage (supUEs ues)  -- See Note [MultiWayIf linearity checking]        ; return (HsMultiIf res_ty alts') }   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } @@ -1157,7 +1182,7 @@  -} --- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression+-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression -- that matches on the constructors of the record @r@, as described in -- Note [Record Updates]. --

@@ -908,7 +908,7 @@     loc = getLocA (dropWildCards hs_ty)     ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { let poly_ty = idType poly_id

@@ -2824,40 +2824,55 @@  ----- How tracking works -* When two Givens are the same, we drop the evidence for the one+(RC1) When two Givens are the same, we drop the evidence for the one   that requires more superclass selectors. This is done-  according to Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.+  according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. -* The ic_need fields of an Implic records in-scope (given) evidence+(RC2) The ic_need fields of an Implic records in-scope (given) evidence   variables bound by the context, that were needed to solve this   implication (so far).  See the declaration of Implication. -* When the constraint solver finishes solving all the wanteds in+(RC3) setImplicationStatus:+  When the constraint solver finishes solving all the wanteds in   an implication, it sets its status to IC_Solved    - The ics_dead field, of IC_Solved, records the subset of this     implication's ic_given that are redundant (not needed). -* We compute which evidence variables are needed by an implication-  in setImplicationStatus.  A variable is needed if+  - We compute which evidence variables are needed by an implication+    in setImplicationStatus.  A variable is needed if     a) it is free in the RHS of a Wanted EvBind,     b) it is free in the RHS of an EvBind whose LHS is needed, or     c) it is in the ics_need of a nested implication. -* After computing which variables are needed, we then look at the-  remaining variables for internal redundancies. This is case (b)-  from above. This is also done in setImplicationStatus.-  Note that we only look for case (b) if case (a) shows up empty,-  as exemplified below.+  - After computing which variables are needed, we then look at the+    remaining variables for internal redundancies. This is case (b)+    from above. This is also done in setImplicationStatus.+    Note that we only look for case (b) if case (a) shows up empty,+    as exemplified below. -* We need to be careful not to discard an implication-  prematurely, even one that is fully solved, because we might-  thereby forget which variables it needs, and hence wrongly-  report a constraint as redundant.  But we can discard it once-  its free vars have been incorporated into its parent; or if it-  simply has no free vars. This careful discarding is also-  handled in setImplicationStatus.+  - We need to be careful not to discard an implication+    prematurely, even one that is fully solved, because we might+    thereby forget which variables it needs, and hence wrongly+    report a constraint as redundant.  But we can discard it once+    its free vars have been incorporated into its parent; or if it+    simply has no free vars. This careful discarding is also+    handled in setImplicationStatus. +(RC4) We do not want to report redundant constraints for implications+  that come from quantified constraints.  Example #23323:+     data T a+     instance Show (T a) where ...  -- No context!+     foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int+     bar = foo @T @Eq++  The call to `foo` gives us+    [W] d : (forall a. Eq a => Show (T a))+  To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint:+    forall a. Eq a =>  [W] ds : Show (T a)+  and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a`+  constraint.  But we don't want to report it as redundant!+ * Examples:      f, g, h :: (Eq a, Ord a) => a -> Bool@@ -3124,6 +3139,48 @@ *                          Defaulting and disambiguation                        * *                                                                               * *********************************************************************************++Note [Defaulting plugins]+~~~~~~~~~~~~~~~~~~~~~~~~~+Defaulting plugins enable extending or overriding the defaulting+behaviour. In `applyDefaulting`, before the built-in defaulting+mechanism runs, the loaded defaulting plugins are passed the+`WantedConstraints` and get a chance to propose defaulting assignments+based on them.++Proposals are represented as `[DefaultingProposal]` with each proposal+consisting of a type variable to fill-in, the list of defaulting types to+try in order, and a set of constraints to check at each try. This is+the same representation (albeit in a nicely packaged-up data type) as+the candidates generated by the built-in defaulting mechanism, so the+actual trying of proposals is done by the same `disambigGroup` function.++Wrinkle (DP1): The role of `WantedConstraints`++  Plugins are passed `WantedConstraints` that can perhaps be+  progressed on by defaulting. But a defaulting plugin is not a solver+  plugin, its job is to provide defaulting proposals, i.e. mappings of+  type variable to types. How do plugins know which type variables+  they are supposed to default?++  The `WantedConstraints` passed to the defaulting plugin are zonked+  beforehand to ensure all remaining metavariables are unfilled. Thus,+  the `WantedConstraints` serve a dual purpose: they are both the+  constraints of the given context that can act as hints to the+  defaulting, as well as the containers of the type variables under+  consideration for defaulting.++Wrinkle (DP2): Interactions between defaulting mechanisms++  In the general case, we have multiple defaulting plugins loaded and+  there is also the built-in defaulting mechanism. In this case, we+  have to be careful to keep the `WantedConstraints` passed to the+  plugins up-to-date by zonking between successful defaulting+  rounds. Otherwise, two plugins might come up with a defaulting+  proposal for the same metavariable; if the first one is accepted by+  `disambigGroup` (thus the meta gets filled), the second proposal+  becomes invalid (see #23821 for an example).+ -}  applyDefaultingRules :: WantedConstraints -> TcS Bool@@ -3140,12 +3197,14 @@        ; tcg_env <- TcS.getGblEnv        ; let plugins = tcg_defaulting_plugins tcg_env -       ; plugin_defaulted <- if null plugins then return [] else+       -- Run any defaulting plugins+       -- See Note [Defaulting plugins] for an overview+       ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else            do {              ; traceTcS "defaultingPlugins {" (ppr wanteds)-             ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins+             ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins              ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)-             ; return defaultedGroups+             ; return (wanteds, defaultedGroups)              }         ; let groups = findDefaultableGroups info wanteds@@ -3169,8 +3228,14 @@                     groups                ; traceTcS "defaultingPlugin " $ ppr defaultedGroups                ; case defaultedGroups of-                 [] -> return False-                 _  -> return True+                 [] -> return (wanteds, False)+                 _  -> do+                     -- If a defaulting plugin solves any tyvars, some of the wanteds+                     -- will have filled-in metavars by now (see wrinkle DP2 of+                     -- Note [Defaulting plugins]). So we re-zonk to make sure later+                     -- defaulting doesn't try to solve the same metavars.+                     wanteds' <- TcS.zonkWC wanteds+                     return (wanteds', True)                }  

@@ -8,6 +8,7 @@      unifyWanted,      makeSuperClasses,      StopOrContinue(..), stopWith, continueWith, andWhenContinue,+     rewriteEqEvidence,      solveCallStack    -- For GHC.Tc.Solver   ) where @@ -2528,7 +2529,7 @@                 -> MCoercion                -- :: kind(rhs) ~N kind(lhs)                 -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs+  = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs        ; if | case is_touchable of { Untouchable -> False; _ -> True }             , cterHasNoProblem $                 checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily

@@ -35,6 +35,7 @@ import GHC.Core.InstEnv     ( DFunInstType ) import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Reduction import GHC.Core.Predicate import GHC.Core.Coercion import GHC.Core.FamInstEnv@@ -1572,7 +1573,7 @@                         -> TcType    -- RHS                         -> TcS (StopOrContinue Ct) tryToSolveByUnification work_item ev tv rhs-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs+  = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs        ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs                                                   , ppr is_touchable ]) @@ -2010,7 +2011,7 @@   | otherwise   = do { res <- matchLocalInst pred loc        ; case res of-           OneInst {} -> chooseInstance work_item res+           OneInst {} -> chooseInstance ev res            _          -> continueWith work_item }    where@@ -2025,22 +2026,45 @@ ********************************************************************-}  doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)-doTopReactEqPred work_item eq_rel t1 t2+doTopReactEqPred work_item eq_rel lhs rhs   -- See Note [Looking up primitive equalities in quantified constraints]-  | Just (cls, tys) <- boxEqPred eq_rel t1 t2-  = do { res <- matchLocalInst (mkClassPred cls tys) loc-       ; case res of-           OneInst { cir_mk_ev = mk_ev }-             -> chooseInstance work_item-                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })-           _ -> continueWith work_item }--  | otherwise-  = continueWith work_item+  = do { ev_binds_var <- getTcEvBindsVar+       ; ics <- getInertCans+       ; if isWanted ev                       -- Never look up Givens in quantified constraints+         && not (null (inert_insts ics))      -- Shortcut common case+         && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications]+         then try_for_qci+         else continueWith work_item }   where     ev   = ctEvidence work_item     loc = ctEvLoc ev +    role = eqRelRole eq_rel+    try_for_qci  -- First try looking for (lhs ~ rhs)+       | Just (cls, tys) <- boxEqPred eq_rel lhs rhs+       = do { res <- matchLocalInst (mkClassPred cls tys) loc+            ; traceTcS "final_qci_check:1" (ppr (mkClassPred cls tys))+            ; case res of+                OneInst { cir_mk_ev = mk_ev }+                  -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })+                _ -> try_swapping }+       | otherwise+       = continueWith work_item++    try_swapping  -- Now try looking for (rhs ~ lhs)  (see #23333)+       | Just (cls, tys) <- boxEqPred eq_rel rhs lhs+       = do { res <- matchLocalInst (mkClassPred cls tys) loc+            ; traceTcS "final_qci_check:2" (ppr (mkClassPred cls tys))+            ; case res of+                OneInst { cir_mk_ev = mk_ev }+                  -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped+                                      (mkReflRedn role rhs) (mkReflRedn role lhs)+                        ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) }+                _ -> do { traceTcS "final_qci_check:3" (ppr work_item)+                        ; continueWith work_item }}+       | otherwise+       = continueWith work_item+     mk_eq_ev cls tys mk_ev evs       = case (mk_ev evs) of           EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)@@ -2279,7 +2303,7 @@                OneInst { cir_what = what }                   -> do { insertSafeOverlapFailureTcS what work_item                         ; addSolvedDict what ev cls xis-                        ; chooseInstance work_item lkup_res }+                        ; chooseInstance ev lkup_res }                _  -> -- NoInstance or NotSure                      -- We didn't solve it; so try functional dependencies with                      -- the instance environment@@ -2312,27 +2336,23 @@ tryLastResortProhibitedSuperclass _ work_item   = continueWith work_item -chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)+chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct) chooseInstance work_item                (OneInst { cir_new_theta = theta                         , cir_what      = what                         , cir_mk_ev     = mk_ev })-  = do { traceTcS "doTopReact/found instance for" $ ppr ev+  = do { traceTcS "doTopReact/found instance for" $ ppr work_item        ; deeper_loc <- checkInstanceOK loc what pred        ; checkReductionDepth deeper_loc pred-       ; evb <- getTcEvBindsVar-       ; if isCoEvBindsVar evb-         then continueWith work_item-                  -- See Note [Instances in no-evidence implications]-         else-           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta-              ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))-              ; emitWorkNC (freshGoals evc_vars)-              ; stopWith ev "Dict/Top (solved wanted)" }}+       ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar)+                    (ppr work_item)+       ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta+       ; setEvBindIfWanted work_item (mk_ev (map getEvExpr evc_vars))+       ; emitWorkNC (freshGoals evc_vars)+       ; stopWith work_item "Dict/Top (solved wanted)" }   where-     ev         = ctEvidence work_item-     pred       = ctEvPred ev-     loc        = ctEvLoc ev+     pred       = ctEvPred work_item+     loc        = ctEvLoc work_item  chooseInstance work_item lookup_res   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)

@@ -1267,35 +1267,37 @@   ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)   ppr Untouchable                   = text "Untouchable" -touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult--- This is the key test for untouchability:+touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType)+-- ^ This is the key test for untouchability: -- See Note [Unification preconditions] in GHC.Tc.Utils.Unify -- and Note [Solve by unification] in GHC.Tc.Solver.Interact+--+-- Returns a new rhs type, as this function can turn make some metavariables concrete. touchabilityTest flav tv1 rhs   | flav /= Given  -- See Note [Do not unify Givens]   , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1-  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs-       ; if not can_continue_solving-         then return Untouchable-         else-    do { ambient_lvl  <- getTcLevel+  = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs+       ; case continue_solving of+       { Nothing -> return (Untouchable, rhs)+       ; Just rhs ->+    do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $+                                        nonDetEltsUniqSet               $+                                        tyCoVarsOfType rhs+       ; ambient_lvl  <- getTcLevel        ; given_eq_lvl <- getInnermostGivenEqLevel         ; if | tv_lvl `sameDepthAs` ambient_lvl-            -> return TouchableSameLevel+            -> return (TouchableSameLevel, rhs)              | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities             , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes-            -> return (TouchableOuterLevel free_metas tv_lvl)+            -> return (TouchableOuterLevel free_metas tv_lvl, rhs)              | otherwise-            -> return Untouchable } }+            -> return (Untouchable, rhs) } } }   | otherwise-  = return Untouchable+  = return (Untouchable, rhs)   where-     (free_metas, free_skols) = partition isPromotableMetaTyVar $-                                nonDetEltsUniqSet               $-                                tyCoVarsOfType rhs       does_not_escape tv_lvl fv        | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv@@ -1723,8 +1725,8 @@ Consider [G] forall a. blah => a ~ T          [W] S ~# T -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it+Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T)+in the quantified constraints, and wraps the (boxed) evidence it gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put that term into a coercion, so we add a value binding     h = eq_sel (...)@@ -1940,23 +1942,21 @@      -- See Detail (8) of the Note.    = do { should_break <- final_check-       ; if should_break then do { redn <- go rhs-                                 ; return (Just redn) }-                         else return Nothing }+       ; mapM go should_break }   where     flavour = ctEvFlavour ev     eq_rel  = ctEvEqRel ev      final_check = case flavour of-      Given  -> return True+      Given  -> return $ Just rhs       Wanted    -- Wanteds work only with a touchable tyvar on the left                 -- See "Wanted" section of the Note.         | TyVarLHS lhs_tv <- lhs ->-          do { result <- touchabilityTest Wanted lhs_tv rhs+          do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs              ; return $ case result of-                          Untouchable -> False-                          _           -> True }-        | otherwise -> return False+                          Untouchable -> Nothing+                          _           -> Just rhs }+        | otherwise -> return Nothing      -- This could be considerably more efficient. See Detail (5) of Note.     go :: TcType -> TcS ReductionN

@@ -64,6 +64,8 @@  import GHC.Unit.Module +import GHC.Rename.Utils (wrapGenSpan)+ import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel@@ -966,10 +968,11 @@     -- mentions this particular record selector     deflt | all dealt_with all_cons = []           | otherwise = [mkSimpleMatch CaseAlt-                            [L loc' (WildPat noExtField)]-                            (mkHsApp (L loc' (HsVar noExtField-                                         (L locn (getName rEC_SEL_ERROR_ID))))-                                     (L loc' (HsLit noComments msg_lit)))]+                            [wrapGenSpan (WildPat noExtField)]+                            (wrapGenSpan+                                (HsApp noComments+                                    (wrapGenSpan (HsVar noExtField (wrapGenSpan (getName rEC_SEL_ERROR_ID))))+                                    (wrapGenSpan (HsLit noComments msg_lit))))]          -- Do not add a default case unless there are unmatched         -- constructors.  We must take account of GADTs, else we

@@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf      #-}+{-# LANGUAGE RecursiveDo     #-} {-# LANGUAGE TupleSections   #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -500,8 +501,17 @@ newInferExpType = new_inferExpType Nothing  newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR-newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)+newInferExpTypeFRR frr_orig+  = do { th_stage <- getStage+       ; if+          -- See [Wrinkle: Typed Template Haskell]+          -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.+          | Brack _ (TcPending {}) <- th_stage+          -> new_inferExpType Nothing +          | otherwise+          -> new_inferExpType (Just frr_orig) }+ new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType new_inferExpType mb_frr_orig   = do { u <- newUnique@@ -556,20 +566,28 @@  inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl-                      , ir_ref = ref })+                      , ir_ref = ref+                      , ir_frr = mb_frr })   = do { mb_inferred_ty <- readTcRef ref        ; tau <- case mb_inferred_ty of             Just ty -> do { ensureMonoType ty                             -- See Note [inferResultToType]                           ; return ty }-            Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy-                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)-                            -- See Note [TcLevel of ExpType]+            Nothing -> do { tau <- new_meta                           ; writeMutVar ref (Just tau)                           ; return tau }        ; traceTc "Forcing ExpType to be monomorphic:"                  (ppr u <+> text ":=" <+> ppr tau)        ; return tau }+  where+    -- See Note [TcLevel of ExpType]+    new_meta = case mb_frr of+      Nothing  ->  do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+                      ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }+      Just frr -> mdo { rr  <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy+                      ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)+                      ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr+                      ; return tau }  {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -892,6 +910,13 @@                         , mtv_ref   = ref                         , mtv_tclvl = tclvl }) } +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails+newConcreteTvDetailsAtLevel conc_orig tclvl+  = do { ref <- newMutVar Flexi+       ; return (MetaTv { mtv_info  = ConcreteTv conc_orig+                        , mtv_ref   = ref+                        , mtv_tclvl = tclvl }) }+ cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv   = assert (isTcTyVar tv) $@@ -937,7 +962,7 @@  -------------------- -- Works with both type and kind variables-writeMetaTyVar :: TcTyVar -> TcType -> TcM ()+writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar  writeMetaTyVar tyvar ty@@ -955,7 +980,7 @@   = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)  ---------------------writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()+writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; -- the ref cell must be for the same tyvar writeMetaTyVarRef tyvar ref ty@@ -1120,6 +1145,13 @@         ; name    <- newMetaTyVarName (fsLit "p")         ; return (mkTyVarTy (mkTcTyVar name kind details)) } +newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType+newConcreteTyVarAtLevel conc_orig tc_lvl kind+  = do  { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl+        ; name    <- newMetaTyVarName (fsLit "c")+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }++ {- ********************************************************************* *                                                                      *           Finding variables to quantify over@@ -1823,6 +1855,17 @@        ; writeMetaTyVar tv manyDataConTy        ; return True } +  | isConcreteTyVar tv+    -- We don't want to quantify; but neither can we default to+    -- anything sensible.  (If it has kind RuntimeRep or Levity, as is+    -- often the case, it'll have been caught earlier by earlier+    -- cases. So in this exotic situation we just promote.  Not very+    -- satisfing, but it's very much a corner case: #23051)+    -- We should really implement the plan in #20686.+  = do { lvl <- getTcLevel+       ; _ <- promoteMetaTyVarTo lvl tv+       ; return True }+   | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it   = default_kind_var tv @@ -2237,7 +2280,7 @@ *                                                                      * ********************************************************************* -} -promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool+promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool -- When we float a constraint out of an implication we must restore -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion@@ -2255,7 +2298,7 @@    = return False  -- Returns whether or not *any* tyvar is defaulted-promoteTyVarSet :: TcTyVarSet -> TcM Bool+promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool promoteTyVarSet tvs   = do { tclvl <- getTcLevel        ; bools <- mapM (promoteMetaTyVarTo tclvl)  $

@@ -2072,10 +2072,10 @@            -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles       , cterHasNoProblem (checkTyVarEq tv1 ty2)            -- See Note [Prevent unification with type families]-      = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2-           ; if not can_continue_solving-             then not_ok_so_defer-             else+      = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2+           ; case mb_continue_solving of+           { Nothing -> not_ok_so_defer+           ; Just ty2 ->         do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1)            ; traceTc "uUnfilledVar2 ok" $              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)@@ -2089,9 +2089,9 @@              then do { writeMetaTyVar tv1 ty2                      ; return (mkNomReflCo ty2) } -             else defer }} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical-                           -- Note [Equalities with incompatible kinds] for how-                           -- this will be dealt with in the solver+             else defer }}} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical+                            -- Note [Equalities with incompatible kinds] for how+                            -- this will be dealt with in the solver        | otherwise       = not_ok_so_defer@@ -2111,39 +2111,38 @@ -- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of -- Note [Unification preconditions]; returns True if these conditions -- are satisfied. But see the Note for other preconditions, too.-startSolvingByUnification :: MetaInfo -> TcType  -- zonked-                          -> TcM Bool+startSolvingByUnification :: MetaInfo -> TcType -- zonked+                          -> TcM (Maybe TcType) startSolvingByUnification _ xi   | hasCoercionHoleTy xi  -- (COERCION-HOLE) check-  = return False+  = return Nothing startSolvingByUnification info xi   = case info of-      CycleBreakerTv -> return False+      CycleBreakerTv -> return Nothing       ConcreteTv conc_orig ->-        do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi+        do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi                  -- NB: makeTypeConcrete has the side-effect of turning                  -- some TauTvs into ConcreteTvs, e.g.                  -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])                  -- will write `beta[tau] := beta[conc]`.                  ---                 -- We don't need to track these unifications for the purposes-                 -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),-                 -- as they don't unlock any further progress.+                 -- We return the new type, so that callers of this function+                 -- aren't required to zonk.            ; case not_conc_reasons of-               [] -> return True-               _  -> return False }+               [] -> return $ Just xi+               _  -> return Nothing }       TyVarTv ->         case getTyVar_maybe xi of-           Nothing -> return False+           Nothing -> return Nothing            Just tv ->              case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle-                SkolemTv {} -> return True-                RuntimeUnk  -> return True+                SkolemTv {} -> return $ Just xi+                RuntimeUnk  -> return $ Just xi                 MetaTv { mtv_info = info } ->                   case info of-                    TyVarTv -> return True-                    _       -> return False-      _ -> return True+                    TyVarTv -> return $ Just xi+                    _       -> return Nothing+      _ -> return $ Just xi  swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2

@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence+import GHC.Tc.Errors.Types  import GHC.Core.TyCo.Ppr     ( pprTyVar ) import GHC.Core.TyCon@@ -1733,7 +1734,7 @@ T9198 and #19668.  So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type+zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi                           , ze_tv_env = tv_env                           , ze_meta_tv_env = mtv_env_ref }) tv@@ -1806,6 +1807,9 @@         | isMultiplicityTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)               ; return manyDataConTy }+        | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv+        -> do { addErr $ TcRnCannotDefaultConcrete origin+              ; return (anyTypeOfKind zonked_kind) }         | otherwise         -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)               ; return (anyTypeOfKind zonked_kind) }

@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.6.2.20231121+version: 9.6.3.20231014 license: BSD-3-Clause license-file: LICENSE category: Development@@ -90,7 +90,7 @@         stm,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 9.6.2.20231121+        ghc-lib-parser == 9.6.3.20231014     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:         BangPatterns

@@ -97,6 +97,9 @@ /* Define to 1 if <alloca.h> works. */ #define HAVE_ALLOCA_H 1 +/* Does the toolchain use ARMv8 outline atomics */+/* #undef HAVE_ARM_OUTLINE_ATOMICS */+ /* Define to 1 if you have the <bfd.h> header file. */ /* #undef HAVE_BFD_H */ @@ -198,6 +201,9 @@  /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1++/* Define to 1 if you have the `mingwex' library (-lmingwex). */+/* #undef HAVE_LIBMINGWEX */  /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0