ghc 9.6.2 → 9.6.3

raw patch · 71 files changed

+2026/−972 lines, 71 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

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

API changes (from Hackage documentation)

Files

• GHC/Cmm.hs +2/−3
• GHC/Cmm/CLabel.hs +6/−2
• GHC/Cmm/Lexer.hs +2/−2
• GHC/Cmm/MachOp.hs +21/−1
• GHC/CmmToAsm/AArch64/CodeGen.hs +42/−21
• GHC/CmmToAsm/Ppr.hs +4/−0
• GHC/CmmToAsm/X86/CodeGen.hs +24/−2
• GHC/Core/Coercion.hs +6/−2
• GHC/Core/DataCon.hs +28/−11
• GHC/Core/Opt/Arity.hs +50/−37
• GHC/Core/Opt/DmdAnal.hs +122/−84
• GHC/Core/Opt/SpecConstr.hs +8/−7
• GHC/Core/Opt/Specialise.hs +28/−5
• GHC/Core/Rules.hs +10/−4
• GHC/Core/Tidy.hs +2/−2
• GHC/CoreToStg/Prep.hs +1/−1
• GHC/Driver/CodeOutput.hs +1/−1
• GHC/Driver/Config/StgToCmm.hs +2/−0
• GHC/Driver/Flags.hs +52/−14
• GHC/Driver/GenerateCgIPEStub.hs +202/−95
• GHC/Driver/Main.hs +30/−10
• GHC/Driver/Make.hs +16/−16
• GHC/Driver/Pipeline.hs +18/−7
• GHC/Driver/Session.hs +11/−5
• GHC/Hs/Utils.hs +1/−1
• GHC/HsToCore/Match.hs +71/−15
• GHC/HsToCore/Pmc.hs +3/−3
• GHC/Iface/Recomp/Flags.hs +4/−1
• GHC/Linker/Static.hs +1/−1
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Runtime/Heap/Layout.hs +3/−3
• GHC/Stg/Debug.hs +2/−2
• GHC/Stg/InferTags/Rewrite.hs +7/−10
• GHC/Stg/Lint.hs +38/−29
• GHC/Stg/Syntax.hs +1/−1
• GHC/Stg/Unarise.hs +26/−19
• GHC/StgToCmm/Closure.hs +110/−8
• GHC/StgToCmm/Config.hs +3/−2
• GHC/StgToCmm/Env.hs +2/−2
• GHC/StgToCmm/Foreign.hs +23/−7
• GHC/StgToCmm/Monad.hs +4/−2
• GHC/StgToCmm/Prim.hs +181/−111
• GHC/StgToCmm/Prof.hs +13/−10
• GHC/StgToCmm/Types.hs +47/−1
• GHC/StgToCmm/Utils.hs +78/−16
• GHC/Tc/Errors.hs +44/−23
• GHC/Tc/Errors/Ppr.hs +9/−0
• GHC/Tc/Errors/Types.hs +14/−1
• GHC/Tc/Gen/Bind.hs +22/−2
• GHC/Tc/Gen/Expr.hs +27/−2
• GHC/Tc/Gen/Head.hs +1/−1
• GHC/Tc/Solver.hs +88/−23
• GHC/Tc/Solver/Canonical.hs +2/−1
• GHC/Tc/Solver/Interact.hs +48/−28
• GHC/Tc/Solver/Monad.hs +24/−24
• GHC/Tc/TyCl/Utils.hs +7/−4
• GHC/Tc/Types.hs +6/−1
• GHC/Tc/Types/Constraint.hs +5/−4
• GHC/Tc/Utils/TcMType.hs +52/−9
• GHC/Tc/Utils/Unify.hs +22/−23
• GHC/Tc/Utils/Zonk.hs +5/−1
• GHC/Types/Demand.hs +174/−162
• GHC/Types/Error/Codes.hs +2/−0
• GHC/Types/Id.hs +2/−0
• GHC/Types/Id/Info.hs +2/−1
• GHC/Types/Literal.hs +3/−2
• GHC/Types/RepType.hs +9/−5
• GHC/Utils/Binary.hs +2/−2
• GHC/Utils/TmpFs.hs +142/−69
• ghc.cabal +4/−4

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

@@ -65,6 +65,7 @@         mkSMAP_DIRTY_infoLabel,         mkBadAlignmentLabel,         mkOutOfBoundsAccessLabel,+        mkMemcpyRangeOverlapLabel,         mkArrWords_infoLabel,         mkSRTInfoLabel, @@ -649,7 +650,8 @@     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel+    mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,+    mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData@@ -667,7 +669,8 @@ mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry-mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo  mkSRTInfoLabel :: Int -> CLabel@@ -1384,6 +1387,7 @@                    ordinary Haskell function of arity 1 that                    allocates a (Just x) box:                       Just = \x -> Just x+    Just_entry:    The entry code for the worker function     Just_closure:  The closure for this worker      Nothing_closure: a statically allocated closure for Nothing

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer (    CmmToken(..), cmmlex,   ) where@@ -385,7 +385,7 @@   , (0,alex_action_20)   ] -{-# LINE 133 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 133 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -51,6 +51,25 @@ assume that the code produced for a MachOp does not introduce new blocks. -} +-- Note [MO_S_MulMayOflo significant width]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are two interpretations in the code about what a multiplication+-- overflow exactly means:+--+-- 1. The result does not fit into the specified width (of type Width.)+-- 2. The result does not fit into a register.+--+-- (2) has some flaws: A following MO_Mul has a width, too. So MO_S_MulMayOflo+-- may signal no overflow, while MO_Mul truncates the result. There are+-- architectures with several register widths and it might be hard to decide+-- what's an overflow and what not. Both attributes can easily lead to subtle+-- bugs.+--+-- (1) has the benefit that its interpretation is completely independent of the+-- architecture. So, the mid-term plan is to migrate to this+-- interpretation/sematics.+ data MachOp   -- Integer operations (insensitive to signed/unsigned)   = MO_Add Width@@ -60,7 +79,8 @@   | MO_Mul Width                -- low word of multiply    -- Signed multiply/divide-  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows. See+                                -- Note [MO_S_MulMayOflo significant width]   | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)   | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)   | MO_S_Neg  Width             -- unary -

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

@@ -1155,8 +1155,12 @@     Pair ty1 ty2 = coercionKind co      go cs co-      | Just (ty, r) <- isReflCo_maybe co-      = Just (mkReflCo r (getNthFromType cs ty))+      | Just (ty, _co_role) <- isReflCo_maybe co+      = let new_role = coercionRole (SelCo cs co)+        in Just (mkReflCo new_role (getNthFromType cs ty))+        -- The role of the result (new_role) does not have to+        -- be equal to _co_role, the role of co, per Note [SelCo].+        -- This was revealed by #23938.      go SelForAll (ForAllCo _ kind_co _)       = Just kind_co

@@ -111,8 +111,8 @@ import Language.Haskell.Syntax.Module.Name  {--Data constructor representation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Data constructor representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration          data T = T !Int ![Int]@@ -213,7 +213,7 @@  * The wrapper (if it exists) takes dcOrigArgTys as its arguments.   The worker takes dataConRepArgTys as its arguments-  If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys+  If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys  * The 'NoDataConRep' case of DataConRep is important. Not only is it   efficient, but it also ensures that the wrapper is replaced by the@@ -586,12 +586,22 @@  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~-dcSourceArity does not take constraints into account,-but dcRepArity does.  For example:+A `DataCon`'s source arity and core representation arity may differ:+`dcSourceArity` does not take constraints into account, but `dcRepArity` does.++The additional arguments taken into account by `dcRepArity` include quantified+dictionaries and coercion arguments, lifted and unlifted (despite the unlifted+coercion arguments having a zero-width runtime representation).+For example:    MkT :: Ord a => a -> T a     dcSourceArity = 1     dcRepArity    = 2 +   MkU :: (b ~ '[]) => U b+    dcSourceArity = 0+    dcRepArity    = 1++ Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A DataCon has two different sets of type variables:@@ -1030,7 +1040,7 @@         Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Not that this representation is still *different* from runtime+Note that this representation is still *different* from runtime representation. (Which is what STG uses after unarise).  This is how T would end up being used in STG post-unarise:@@ -1446,9 +1456,10 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | Gives the number of actual fields in the /representation/ of the--- data constructor. This may be more than appear in the source code;--- the extra ones are the existentially quantified dictionaries+-- | Gives the number of value arguments (including zero-width coercions)+-- stored by the given `DataCon`'s worker in its Core representation. This may+-- differ from the number of arguments that appear in the source code; see also+-- Note [DataCon arities] dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1457,8 +1468,14 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether there are any argument types for this 'DataCon's runtime representation type--- See Note [DataCon arities]+-- | Return whether this `DataCon`'s worker, in its Core representation, takes+-- any value arguments.+--+-- In particular, remember that we include coercion arguments in the arity of+-- the Core representation of the `DataCon` -- both lifted and unlifted+-- coercions, despite the latter having zero-width runtime representation.+--+-- See also Note [DataCon arities]. isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 

@@ -87,6 +87,8 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import Data.Maybe( isJust )+ {- ************************************************************************ *                                                                      *@@ -2303,18 +2305,6 @@      * `/\a. \x. f @(Maybe a) x -->  /\a. f @(Maybe a)`    See Note [Do not eta reduce PAPs] for why we insist on a trivial head. -2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it-   is always sound to reduce /type lambdas/, thus:-        (/\a -> f a)  -->   f-   Moreover, we always want to, because it makes RULEs apply more often:-      This RULE:    `forall g. foldr (build (/\a -> g a))`-      should match  `foldr (build (/\b -> ...something complex...))`-   and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.--   The type checker can insert these eta-expanded versions,-   with both type and dictionary lambdas; hence the slightly-   ad-hoc (all ok_lam bndrs)- Of course, eta reduction is not always sound. See Note [Eta reduction soundness] for when it is. @@ -2353,7 +2343,7 @@ (checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the case where `e` is trivial): - A. It is sound to eta-reduce n arguments as long as n does not exceed the+(A) It is sound to eta-reduce n arguments as long as n does not exceed the     `exprArity` of `e`. (Needs Arity analysis.)     This criterion exploits information about how `e` is *defined*. @@ -2362,7 +2352,7 @@     By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`:     `e 42` diverges when `(\x y. e x y) 42` does not. - S. It is sound to eta-reduce n arguments in an evaluation context in which all+(S) It is sound to eta-reduce n arguments in an evaluation context in which all     calls happen with at least n arguments. (Needs Strictness analysis.)     NB: This treats evaluations like a call with 0 args.     NB: This criterion exploits information about how `e` is *used*.@@ -2389,23 +2379,42 @@     See Note [Eta reduction based on evaluation context] for the implementation     details. This criterion is tested extensively in T21261. - R. Note [Eta reduction in recursive RHSs] tells us that we should not+(R) Note [Eta reduction in recursive RHSs] tells us that we should not     eta-reduce `f` in its own RHS and describes our fix.     There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which     might change a terminating program (think @f `seq` e@) to a non-terminating     one. - E. (See fun_arity in tryEtaReduce.) As a perhaps special case on the+(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the     boundary of (A) and (S), when we know that a fun binder `f` is in     WHNF, we simply assume it has arity 1 and apply (A).  Example:        g f = f `seq` \x. f x     Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom     after the `seq`. This turned up in #7542. + T. If the binders are all type arguments, it's always safe to eta-reduce,+    regardless of the arity of f.+       /\a b. f @a @b  --> f++2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it+   is always sound to reduce /type lambdas/, thus:+        (/\a -> f a)  -->   f+   Moreover, we always want to, because it makes RULEs apply more often:+      This RULE:    `forall g. foldr (build (/\a -> g a))`+      should match  `foldr (build (/\b -> ...something complex...))`+   and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.++   More debatably, we extend this to dictionary arguments too, because the type+   checker can insert these eta-expanded versions, with both type and dictionary+   lambdas; hence the slightly ad-hoc (all ok_lam bndrs).  That is, we eta-reduce+        \(d::Num a). f d   -->   f+   regardless of f's arity. Its not clear whether or not this is important, and+   it is not in general sound.  But that's the way it is right now.+ And here are a few more technical criteria for when it is *not* sound to eta-reduce that are specific to Core and GHC: - L. With linear types, eta-reduction can break type-checking:+(L) With linear types, eta-reduction can break type-checking:       f :: A ⊸ B       g :: A -> B       g = \x. f x@@ -2413,13 +2422,13 @@     complain that g and f don't have the same type. NB: Not unsound in the     dynamic semantics, but unsound according to the static semantics of Core. - J. We may not undersaturate join points.+(J) We may not undersaturate join points.     See Note [Invariants on join points] in GHC.Core, and #20599. - B. We may not undersaturate functions with no binding.+(B) We may not undersaturate functions with no binding.     See Note [Eta expanding primops]. - W. We may not undersaturate StrictWorkerIds.+(W) We may not undersaturate StrictWorkerIds.     See Note [CBV Function Ids] in GHC.Types.Id.Info.  Here is a list of historic accidents surrounding unsound eta-reduction:@@ -2663,20 +2672,25 @@     ok_fun (App fun (Type {})) = ok_fun fun     ok_fun (Cast fun _)        = ok_fun fun     ok_fun (Tick _ expr)       = ok_fun expr-    ok_fun (Var fun_id)        = is_eta_reduction_sound fun_id || all ok_lam bndrs+    ok_fun (Var fun_id)        = is_eta_reduction_sound fun_id     ok_fun _fun                = False      ---------------     -- See Note [Eta reduction soundness], this is THE place to check soundness!-    is_eta_reduction_sound fun =-      -- Don't eta-reduce in fun in its own recursive RHSs-      not (fun `elemUnVarSet` rec_ids)               -- criterion (R)-      -- Check that eta-reduction won't make the program stricter...-      && (fun_arity fun >= incoming_arity            -- criterion (A) and (E)-           || all_calls_with_arity incoming_arity)   -- criterion (S)-      -- ... and that the function can be eta reduced to arity 0-      -- without violating invariants of Core and GHC-      && canEtaReduceToArity fun 0 0              -- criteria (L), (J), (W), (B)+    is_eta_reduction_sound fun+      | fun `elemUnVarSet` rec_ids          -- Criterion (R)+      = False -- Don't eta-reduce in fun in its own recursive RHSs++      | cantEtaReduceFun fun                -- Criteria (L), (J), (W), (B)+      = False -- Function can't be eta reduced to arity 0+              -- without violating invariants of Core and GHC++      | otherwise+      = -- Check that eta-reduction won't make the program stricter...+        fun_arity fun >= incoming_arity          -- Criterion (A) and (E)+        || all_calls_with_arity incoming_arity   -- Criterion (S)+        || all ok_lam bndrs                      -- Criterion (T)+     all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd)        -- See Note [Eta reduction based on evaluation context] @@ -2726,19 +2740,18 @@      ok_arg _ _ _ _ = Nothing --- | Can we eta-reduce the given function to the specified arity?+-- | Can we eta-reduce the given function -- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L).-canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool-canEtaReduceToArity fun dest_join_arity dest_arity =-  not $-        hasNoBinding fun -- (B)+cantEtaReduceFun :: Id -> Bool+cantEtaReduceFun fun+  =    hasNoBinding fun -- (B)        -- Don't undersaturate functions with no binding. -    ||  ( isJoinId fun && dest_join_arity < idJoinArity fun ) -- (J)+    ||  isJoinId fun    -- (J)        -- Don't undersaturate join points.        -- See Note [Invariants on join points] in GHC.Core, and #20599 -    || ( dest_arity < idCbvMarkArity fun ) -- (W)+    || (isJust (idCbvMarks_maybe fun)) -- (W)        -- Don't undersaturate StrictWorkerIds.        -- See Note [CBV Function Ids] in GHC.Types.Id.Info. 

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

@@ -886,9 +886,6 @@ see `init_menv` in `matchN`. -} -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv-rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv)- -- * The domain of the TvSubstEnv and IdSubstEnv are the template --   variables passed into the match. --@@ -1105,7 +1102,16 @@  ------------------------  Lambdas --------------------- match renv subst (Lam x1 e1) e2 mco-  | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco)+  | let casted_e2 = mkCastMCo e2 mco+        in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv))+                                       (exprFreeVars casted_e2)+        in_scope_env = ISE in_scope (rv_unf renv)+        -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily+        -- a superset of the free vars of e2; it is only guaranteed a superset of+        -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe+        -- wants an in-scope set that includes all the free vars of its argument.+        -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)+  , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2     -- See Note [Lambdas in the template]   = let renv'  = rnMatchBndr2 renv x1 x2         subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }

@@ -82,7 +82,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. ----- The actual logic is in tidyCbvInfo and takes:+-- The actual logic is in computeCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks.@@ -169,7 +169,7 @@                -- seqList: avoid retaining the original rhs               | otherwise-             = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!"+             = -- pprTraceDebug "computeCbvInfo: Worker seems to take unboxed tuple/sum types!"                --    (ppr fun_id <+> ppr rhs)                asNonWorkerLikeId fun_id 

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

@@ -5,6 +5,7 @@    , GeneralFlag(..)    , Language(..)    , optimisationFlags+   , codeGenFlags     -- * Warnings    , WarningFlag(..)@@ -149,6 +150,7 @@    | Opt_D_no_debug_output    | Opt_D_dump_faststrings    | Opt_D_faststring_stats+   | Opt_D_ipe_stats    deriving (Eq, Show, Enum)  -- | Helper function to query whether a given `DumpFlag` is enabled or not.@@ -211,6 +213,8 @@     | Opt_DistinctConstructorTables    | Opt_InfoTableMap+   | Opt_InfoTableMapWithFallback+   | Opt_InfoTableMapWithStack     | Opt_WarnIsError                    -- -Werror; makes warnings fatal    | Opt_ShowWarnGroups                 -- Show the group a warning belongs to@@ -246,6 +250,7 @@    | Opt_Specialise    | Opt_SpecialiseAggressively    | Opt_CrossModuleSpecialise+   | Opt_PolymorphicSpecialisation    | Opt_InlineGenerics    | Opt_InlineGenericsAggressively    | Opt_StaticArgumentTransformation@@ -467,15 +472,11 @@    | Opt_G_NoOptCoercion    deriving (Eq, Show, Enum) --- Check whether a flag should be considered an "optimisation flag"--- for purposes of recompilation avoidance (see--- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is--- not a guarantee that the flag has no other effect. We could, and--- perhaps should, separate out the flags that have some minor impact on--- program semantics and/or error behavior (e.g., assertions), but--- then we'd need to go to extra trouble (and an additional flag)--- to allow users to ignore the optimisation level even though that--- means ignoring some change.+-- | The set of flags which affect optimisation for the purposes of+-- recompilation avoidance. Specifically, these include flags which+-- affect code generation but not the semantics of the program.+--+-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags) optimisationFlags :: EnumSet GeneralFlag optimisationFlags = EnumSet.fromList    [ Opt_CallArity@@ -507,16 +508,12 @@    , Opt_EnableRewriteRules    , Opt_RegsGraph    , Opt_RegsIterative-   , Opt_PedanticBottoms    , Opt_LlvmTBAA-   , Opt_LlvmFillUndefWithGarbage    , Opt_IrrefutableTuples    , Opt_CmmSink    , Opt_CmmElimCommonBlocks    , Opt_AsmShortcutting-   , Opt_OmitYields    , Opt_FunToThunk-   , Opt_DictsStrict    , Opt_DmdTxDictSel    , Opt_Loopification    , Opt_CfgBlocklayout@@ -525,8 +522,49 @@    , Opt_WorkerWrapper    , Opt_WorkerWrapperUnlift    , Opt_SolveConstantDicts+   ]++-- | The set of flags which affect code generation and can change a program's+-- runtime behavior (other than performance). These include flags which affect:+--+--  * user visible debugging information (e.g. info table provenance)+--  * the ability to catch runtime errors (e.g. -fignore-asserts)+--  * the runtime result of the program (e.g. -fomit-yields)+--  * which code or interface file declarations are emitted+--+-- We also considered placing flags which affect asympototic space behavior+-- (e.g. -ffull-laziness) however this would mean that changing optimisation+-- levels would trigger recompilation even with -fignore-optim-changes,+-- regressing #13604.+--+-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place+-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and+-- therefore would also break #13604.+--+-- See #23369.+codeGenFlags :: EnumSet GeneralFlag+codeGenFlags = EnumSet.fromList+   [ -- Flags that affect runtime result+     Opt_EagerBlackHoling+   , Opt_ExcessPrecision+   , Opt_DictsStrict+   , Opt_PedanticBottoms+   , Opt_OmitYields++     -- Flags that affect generated code+   , Opt_ExposeAllUnfoldings+   , Opt_NoTypeableBinds++     -- Flags that affect catching of runtime errors    , Opt_CatchNonexhaustiveCases-   , Opt_IgnoreAsserts+   , Opt_LlvmFillUndefWithGarbage+   , Opt_DoTagInferenceChecks++     -- Flags that affect debugging information+   , Opt_DistinctConstructorTables+   , Opt_InfoTableMap+   , Opt_InfoTableMapWithStack+   , Opt_InfoTableMapWithFallback    ]  data WarningFlag =

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

@@ -60,6 +60,7 @@         makeDynFlagsConsistent,         positionIndependent,         optimisationFlags,+        codeGenFlags,         setFlagsFromEnvFile,         pprDynFlagsDiff,         flagSpecOf,@@ -2605,6 +2606,8 @@         (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))   , make_ord_flag defGhcFlag "dshow-passes"         (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dipe-stats"+        (setDumpFlag Opt_D_ipe_stats)   , make_ord_flag defGhcFlag "dfaststring-stats"         (setDumpFlag Opt_D_faststring_stats)   , make_ord_flag defGhcFlag "dno-llvm-mangler"@@ -2880,10 +2883,6 @@         -- Caller-CC   , make_ord_flag defGhcFlag "fprof-callers"          (HasArg setCallerCcFilters)-  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"-      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))-  , make_ord_flag defGhcFlag "finfo-table-map"-      (NoArg (setGeneralFlag Opt_InfoTableMap))         ------ Compiler flags -----------------------------------------------    , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))@@ -3475,6 +3474,7 @@   flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,   flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,   flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "polymorphic-specialisation"       Opt_PolymorphicSpecialisation,   flagSpec "inline-generics"                  Opt_InlineGenerics,   flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,   flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,@@ -3511,7 +3511,11 @@         return dflags)),   flagSpec "show-error-context"               Opt_ShowErrorContext,   flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,-  flagSpec "split-sections"                   Opt_SplitSections+  flagSpec "split-sections"                   Opt_SplitSections,+  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,+  flagSpec "info-table-map"                   Opt_InfoTableMap,+  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,+  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback   ]   ++ fHoleFlags @@ -3881,6 +3885,8 @@                 ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)                 ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface)                 ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)                 ] ++ validHoleFitsImpliedGFlags  -- General flags that are switched on/off when other general flags are switched

@@ -209,7 +209,7 @@              -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]              -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = origin-                                 , mg_alts = matches }+                                 , mg_alts = matches }  mkLamCaseMatchGroup :: AnnoBody p body                     => Origin

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

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -110,7 +110,7 @@   , (0,alex_action_1)   ] -{-# LINE 87 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput   { alexInput_position     :: !RealSrcLoc   , alexInput_string       :: !ByteString

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -592,7 +592,7 @@   , (0,alex_action_86)   ] -{-# LINE 704 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 704 "_build/source-dist/ghc-9.6.3-src/ghc-9.6.3/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs   = OpWsPrefix         -- a !b

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

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

@@ -236,7 +236,7 @@         -- which can't be let-bound   | StgConApp   DataCon                 ConstructorNumber-                [StgArg] -- Saturated+                [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg])                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call

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

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

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

@@ -70,6 +70,52 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have   -fomit-interface-pragmas or -fno-code; and we won't read it in if you have   -fignore-interface-pragmas.  (We could revisit this decision.)++Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in `Note [Conveying CAF-info and LFInfo between modules]`,+imported unlifted nullary datacons must have their LambdaFormInfo set to+reflect the fact that they are evaluated . This is necessary as otherwise+references to them may be passed untagged to code that expects tagged+references.++What may be less obvious is that this must be done for not only datacon+workers but also *wrappers*. The reason is found in this program+from #23146:++    module B where++    type NP :: [UnliftedType] -> UnliftedType+    data NP xs where+      UNil :: NP '[]+++    module A where+    import B++    fieldsSam :: NP xs -> NP xs -> Bool+    fieldsSam UNil UNil = True++    x = fieldsSam UNil UNil++Due to its GADT nature, `B.UNil` produces a trivial wrapper++    $WUNil :: NP '[]+    $WUNil = UNil @'[] @~(<co:1>)++which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the+correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged+pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage+of the unlifted nature of its arguments by omitting handling of the zero+tag when scrutinising them.++The fix is straightforward: extend the logic in `mkLFImported` to cover+(nullary) datacon wrappers as well as workers. This is safe because we+know that the wrapper of a nullary datacon will be in WHNF, even if it+includes equalities evidence (since such equalities are not runtime+relevant). This fixed #23146.++See also Note [The LFInfo of Imported Ids] -}  -- | Codegen-generated Id infos, to be passed to downstream via interfaces.@@ -118,7 +164,7 @@         !StandardFormInfo         !Bool           -- True <=> *might* be a function type -  | LFCon               -- A saturated constructor application+  | LFCon               -- A saturated data constructor application         !DataCon        -- The constructor    | LFUnknown           -- Used for function arguments and imported things.

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

@@ -1238,6 +1238,11 @@           = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ]         user_manual =           vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ]+    TcRnCannotDefaultConcrete frr+      -> mkSimpleDecorated $+         ppr (frr_context frr) $$+         text "cannot be assigned a fixed runtime representation," <+>+         text "not even by defaulting."    diagnosticReason = \case     TcRnUnknownMessage m@@ -1646,6 +1651,8 @@       -> ErrorWithoutFlag     TcRnLoopySuperclassSolve{}       -> WarningWithFlag Opt_WarnLoopySuperclassSolve+    TcRnCannotDefaultConcrete{}+      -> ErrorWithoutFlag    diagnosticHints = \case     TcRnUnknownMessage m@@ -2064,6 +2071,8 @@         cls_or_qc = case ctLocOrigin wtd_loc of           ScOrigin c_or_q _ -> c_or_q           _                 -> IsClsInst -- shouldn't happen+    TcRnCannotDefaultConcrete{}+      -> [SuggestAddTypeSignatures UnnamedBinding]    diagnosticCode = constructorCode 

@@ -2793,6 +2793,17 @@                            -> PredType -- ^ Wanted 'PredType'                            -> TcRnMessage +  {- TcRnCannotDefaultConcrete is an error occurring when a concrete+    type variable cannot be defaulted.++    Test cases:+      T23153+  -}+  TcRnCannotDefaultConcrete+    :: !FixedRuntimeRepOrigin+    -> TcRnMessage++   deriving Generic  -- | Things forbidden in @type data@ declarations.@@ -3322,7 +3333,9 @@   = EI { ei_pred     :: PredType         -- report about this          -- The ei_pred field will never be an unboxed equality with          -- a (casted) tyvar on the right; this is guaranteed by the solver-       , ei_evdest   :: Maybe TcEvDest   -- for Wanteds, where to put evidence+       , ei_evdest   :: Maybe TcEvDest+         -- ^ for Wanteds, where to put the evidence+         --   for Givens, Nothing        , ei_flavour  :: CtFlavour        , ei_loc      :: CtLoc        , ei_m_reason :: Maybe CtIrredReason  -- if this ErrorItem was made from a

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

@@ -1774,7 +1774,12 @@           <+> ppr (deProposalCts p)  type DefaultingPluginResult = [DefaultingProposal]-type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult+type FillDefaulting+  = WantedConstraints+      -- Zonked constraints containing the unfilled metavariables that+      -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins]+      -- in GHC.Tc.Solver+  -> TcPluginM [DefaultingProposal]  -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin

@@ -1338,6 +1338,7 @@       -- NB: including stuff used by nested implications that have since       --     been discarded       -- See Note [Needed evidence variables]+      -- and (RC2) in Note [Tracking redundant constraints]a       ic_need_inner :: VarSet,    -- Includes all used Given evidence       ic_need_outer :: VarSet,    -- Includes only the free Given evidence                                   --  i.e. ic_need_inner after deleting@@ -2127,10 +2128,10 @@ holes. The idea is that we wish to report the "root cause" -- the error that rewrote all the others. -Worry: It seems possible that *all* unsolved wanteds are rewritten by other-unsolved wanteds, so that e.g. w1 has w2 in its rewriter set, and w2 has-w1 in its rewiter set. We are unable to come up with an example of this in-practice, however, and so we believe this case cannot happen.+Wrinkle: In #22707, we have a case where all of the Wanteds have rewritten+each other. In order to report /some/ error in this case, we simply report+all the Wanteds. The user will get a perhaps-confusing error message, but+they've written a confusing program!  Note [Avoiding rewriting cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

@@ -43,23 +43,20 @@     -- ** Manipulating Boxity of a Demand     unboxDeeplyDmd, -    -- * Demand environments-    DmdEnv, emptyDmdEnv,-    keepAliveDmdEnv, reuseEnv,-     -- * Divergence     Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, +    -- * Demand environments+    DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,+    reuseEnv,+     -- * Demand types     DmdType(..), dmdTypeDepth,     -- ** Algebra     nopDmdType, botDmdType,-    lubDmdType, plusDmdType, multDmdType,-    -- *** PlusDmdArg-    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,+    lubDmdType, plusDmdType, multDmdType, discardArgDmds,     -- ** Other operations     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,-    keepAliveDmdType,      -- * Demand signatures     DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,@@ -85,9 +82,8 @@  import GHC.Prelude -import GHC.Types.Var ( Var, Id )+import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe   ( orElse )@@ -1054,7 +1050,7 @@  argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info]-argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args+argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args   | unsaturated_call = []   | otherwise = go arg_ds   where@@ -1466,7 +1462,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'+-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be@@ -1737,112 +1733,131 @@ -}  -- Subject to Note [Default demand on free variables and arguments]-type DmdEnv = VarEnv Demand+-- | Captures the result of an evaluation of an expression, by+--+--   * Listing how the free variables of that expression have been evaluted+--     ('de_fvs')+--   * Saying whether or not evaluation would surely diverge ('de_div')+--+-- See Note [Demand env Equality].+data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } -emptyDmdEnv :: DmdEnv-emptyDmdEnv = emptyVarEnv+instance Eq DmdEnv where+  DE fv1 div1 == DE fv2 div2+    = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2+    where+      canonicalise div fv = filterUFM (/= defaultFvDmd div) fv +mkEmptyDmdEnv :: Divergence -> DmdEnv+mkEmptyDmdEnv div = DE emptyVarEnv div++-- | Build a potentially terminating 'DmdEnv' from a finite map that says what+-- has been evaluated so far+mkTermDmdEnv :: VarEnv Demand -> DmdEnv+mkTermDmdEnv fvs = DE fvs topDiv++nopDmdEnv :: DmdEnv+nopDmdEnv = mkEmptyDmdEnv topDiv++botDmdEnv :: DmdEnv+botDmdEnv = mkEmptyDmdEnv botDiv++exnDmdEnv :: DmdEnv+exnDmdEnv = mkEmptyDmdEnv exnDiv++lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div+  where+    -- See Note [Demand env Equality]+    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)+    lub_div = lubDivergence d1 d2++addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv+addVarDmdEnv env@(DE fvs div) id dmd+  = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div++plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+plusDmdEnv (DE fv1 d1) (DE fv2 d2)+  -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.+  | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd+  = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient+  | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd+  = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient+  | otherwise+  = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))+       (d1 `plusDivergence` d2)++-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum'+plusDmdEnvs :: [DmdEnv] -> DmdEnv+plusDmdEnvs []   = nopDmdEnv+plusDmdEnvs pdas = foldl1' plusDmdEnv pdas+ multDmdEnv :: Card -> DmdEnv -> DmdEnv-multDmdEnv C_11 env = env-multDmdEnv C_00 _   = emptyDmdEnv-multDmdEnv n    env = mapVarEnv (multDmd n) env+multDmdEnv C_11 env          = env+multDmdEnv C_00 _            = nopDmdEnv+multDmdEnv n    (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div)  reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N --- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have--- /some/ usage in the returned demand types -- they are not Absent.--- See Note [Absence analysis for stable unfoldings and RULES]---     in "GHC.Core.Opt.DmdAnal".-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv-keepAliveDmdEnv env vs-  = nonDetStrictFoldVarSet add env vs-  where-    add :: Id -> DmdEnv -> DmdEnv-    add v env = extendVarEnv_C add_dmd env v topDmd+lookupDmdEnv :: DmdEnv -> Id -> Demand+-- See Note [Default demand on free variables and arguments]+lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div -    add_dmd :: Demand -> Demand -> Demand-    -- If the existing usage is Absent, make it used-    -- Otherwise leave it alone-    add_dmd dmd _ | isAbsDmd dmd = topDmd-                  | otherwise    = dmd+delDmdEnv :: DmdEnv -> Id -> DmdEnv+delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div  -- | Characterises how an expression -----    * Evaluates its free variables ('dt_env')+--    * Evaluates its free variables ('dt_env') including divergence info --    * Evaluates its arguments ('dt_args')---    * Diverges on every code path or not ('dt_div') ----- Equality is defined modulo 'defaultFvDmd's in 'dt_env'.--- See Note [Demand type Equality]. data DmdType   = DmdType-  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  { dt_env  :: !DmdEnv     -- ^ Demands on free variables.+                           -- See Note [Demand type Divergence]   , dt_args :: ![Demand]   -- ^ Demand on arguments-  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.-                          -- See Note [Demand type Divergence]   } --- | See Note [Demand type Equality].+-- | See Note [Demand env Equality]. instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) =  div1 == div2 && ds1 == ds2 -- cheap checks first-                              && canonicalise div1 fv1 == canonicalise div2 fv2-       where-         canonicalise div fv = filterUFM (/= defaultFvDmd div) fv+  DmdType env1 ds1 == DmdType env2 ds2+    = ds1 == ds2 -- cheap checks first+      && env1 == env2  -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div+lubDmdType d1 d2 = DmdType lub_fv lub_ds   where     n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1-    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2--    -- See Note [Demand type Equality]-    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)+    (DmdType fv1 ds1) = etaExpandDmdType n d1+    (DmdType fv2 ds2) = etaExpandDmdType n d2     lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--type PlusDmdArg = (DmdEnv, Divergence)--mkPlusDmdArg :: DmdEnv -> PlusDmdArg-mkPlusDmdArg env = (env, topDiv)+    lub_fv = lubDmdEnv fv1 fv2 -toPlusDmdArg :: DmdType -> PlusDmdArg-toPlusDmdArg (DmdType fv _ r) = (fv, r)+discardArgDmds :: DmdType -> DmdEnv+discardArgDmds (DmdType fv _) = fv -plusDmdType :: DmdType -> PlusDmdArg -> DmdType-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'plus*']-    -- 'plus' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd-  = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient-  | otherwise-  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))-            ds1-            (r1 `plusDivergence` t2)+plusDmdType :: DmdType -> DmdEnv -> DmdType+plusDmdType (DmdType fv ds) fv'+  -- See Note [Asymmetry of plusDmdType]+  -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation.+  = DmdType (plusDmdEnv fv fv') ds  botDmdType :: DmdType-botDmdType = DmdType emptyDmdEnv [] botDiv+botDmdType = DmdType botDmdEnv []  -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv--isNopDmdType :: DmdType -> Bool-isNopDmdType (DmdType env args div)-  = div == topDiv && null args && isEmptyVarEnv env+nopDmdType = DmdType nopDmdEnv []  -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType-exnDmdType = DmdType emptyDmdEnv [] exnDiv+exnDmdType = DmdType exnDmdEnv []  dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args@@ -1851,7 +1866,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType-etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}+etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env}   | n == depth = d   | n >  depth = d{dt_args = inc_ds}   | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)@@ -1863,7 +1878,7 @@         --  * Divergence is still valid:         --    - A dead end after 2 arguments stays a dead end after 3 arguments         --    - The remaining case is Dunno, which is already topDiv-        inc_ds = take n (ds ++ repeat (defaultArgDmd div))+        inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env)))  -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType.@@ -1875,30 +1890,27 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})-splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)+splitDmdTy ty@DmdType{dt_env=env}       = (defaultArgDmd (de_div env), ty)  multDmdType :: Card -> DmdType -> DmdType-multDmdType n (DmdType fv args res_ty)+multDmdType n (DmdType fv args)   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $     DmdType (multDmdEnv n fv)             (map (multDmd n) args)-            (multDivergence n res_ty)  peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)+peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                            (DmdType fv' ds, dmd)   where   -- Force these arguments so that old `Env` is not retained.-  !fv' = fv `delVarEnv` id-  -- See Note [Default demand on free variables and arguments]-  !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res+  !fv' = fv `delDmdEnv` id+  !dmd = lookupDmdEnv fv id  addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res+addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds)  findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultFvDmd res+findIdDemand (DmdType fv _) id = lookupDmdEnv fv id  -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is@@ -1914,11 +1926,6 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType --- | See 'keepAliveDmdEnv'.-keepAliveDmdType :: DmdType -> VarSet -> DmdType-keepAliveDmdType (DmdType fvs ds res) vars =-  DmdType (fvs `keepAliveDmdEnv` vars) ds res- {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis]@@ -1974,32 +1981,25 @@ strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand type Equality]+Note [Demand env Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-What is the difference between the DmdType <L>{x->A} and <L>?+What is the difference between the Demand env {x->A} and {}? Answer: There is none! They have the exact same semantics, because any var that-is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on-the divergence of the demand type 'dt_div'.-Similarly, <B>b{x->B, y->A} is the same as <B>b{y->A}, because the default FV-demand of BotDiv is B. But neither is equal to <B>b, because y has demand B in+is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on+the divergence of the demand env 'de_div'.+Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV+demand of BotDiv is B. But neither is equal to b{}, because y has demand B in the latter, not A as before. -NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the-demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along-a 'Divergence', for example.--The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity-issues during fixed-point iteration (<L>{x->A} /= <L> /= <L>{x->A} /= ...).-It does so by filtering out any default FV demands prior to comparing 'dt_env'.-An alternative would be to maintain an invariant that there are no default FV demands-in 'dt_env' to begin with, but that seems more involved to maintain in the current-implementation.+The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity+issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...).+It does so by filtering out any default FV demands prior to comparing 'de_fvs'. -Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',-involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the+Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD',+involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the other. -Note [Asymmetry of 'plus*']+Note [Asymmetry of plusDmdType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands!  For example, given (e1 e2), we get@@ -2155,24 +2155,24 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig-mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)-  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div+mkDmdSigForArity arity dmd_ty@(DmdType fvs args)+  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args)   | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)  mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig-mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)+mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds)  mkVanillaDmdSig :: Arity -> Divergence -> DmdSig mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div  splitDmdSig :: DmdSig -> ([Demand], Divergence)-splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)+splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env)  dmdSigDmdEnv :: DmdSig -> DmdEnv-dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env+dmdSigDmdEnv (DmdSig (DmdType env _)) = env  hasDemandEnvSig :: DmdSig -> Bool-hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv+hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv  botSig :: DmdSig botSig = DmdSig botDmdType@@ -2181,23 +2181,23 @@ nopSig = DmdSig nopDmdType  isNopSig :: DmdSig -> Bool-isNopSig (DmdSig ty) = isNopDmdType ty+isNopSig (DmdSig ty) = ty == nopDmdType  -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool-isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res+isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env)  -- | True if the signature diverges or throws an imprecise exception in a saturated call. -- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'. -- See Note [Dead ends] -- and Note [Precise vs imprecise exceptions]. isBottomingSig :: DmdSig -> Bool-isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv+isBottomingSig (DmdSig (DmdType env _)) = de_div env == botDiv  -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool-onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds+onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds  where    demandIsBoxed BotDmd    = True    demandIsBoxed AbsDmd    = True@@ -2217,12 +2217,15 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool-isDeadEndAppSig (DmdSig (DmdType _ ds res)) n-  = isDeadEndDiv res && not (lengthExceeds ds n)+isDeadEndAppSig (DmdSig (DmdType env ds)) n+  = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) +trimBoxityDmdEnv :: DmdEnv -> DmdEnv+trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div+ trimBoxityDmdType :: DmdType -> DmdType-trimBoxityDmdType (DmdType fvs ds res) =-  DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res+trimBoxityDmdType (DmdType env ds) =+  DmdType (trimBoxityDmdEnv env) (map trimBoxity ds)  trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType@@ -2247,12 +2250,11 @@           _ -> trimBoxity to_dmd  transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType-transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res)+transferArgBoxityDmdType _from@(DmdType _ from_ds) to@(DmdType to_env to_ds)   | equalLength from_ds to_ds   = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $-    DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]+    DmdType to_env -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]             (zipWith transferBoxity from_ds to_ds)-            to_res   | otherwise   = trimBoxityDmdType to @@ -2263,10 +2265,10 @@ -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut.-prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))-  | new_args == 0       = sig-  | isNopDmdType dmd_ty = sig-  | otherwise           = DmdSig (DmdType env dmds' res)+prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds))+  | new_args == 0        = sig+  | dmd_ty == nopDmdType = sig+  | otherwise            = DmdSig (DmdType env dmds')   where     dmds' = assertPpr (new_args > 0) (ppr new_args) $             replicate new_args topDmd ++ dmds@@ -2308,7 +2310,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer-dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd+dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd   = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty     -- see Note [Demands from unsaturated function calls]     -- and Note [What are demand signatures?]@@ -2323,7 +2325,7 @@   where     arity = length str_marks     (n, body_sd) = peelManyCalls arity sd-    mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv+    mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)     bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)                    | otherwise          = multDmd n dmd     str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]@@ -2334,11 +2336,11 @@ dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries. -- It should simply apply call_sd directly to the dictionary, I suppose.-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd    | (n, sd') <- peelCallDmd call_sd    , Prod _ sig_ds <- prod    = multDmdType n $-     DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv+     DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]    | otherwise    = nopDmdType -- See Note [Demand transformer for a dictionary selector]   where@@ -2460,9 +2462,12 @@ it should not fall over. -} +zapDmdEnv :: DmdEnv -> DmdEnv+zapDmdEnv (DE _ div) = mkEmptyDmdEnv div+ -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig-zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r+zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds)  zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand@@ -2483,8 +2488,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness --   signature zapUsedOnceSig :: DmdSig -> DmdSig-zapUsedOnceSig (DmdSig (DmdType env ds r))-    = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)+zapUsedOnceSig (DmdSig (DmdType env ds))+    = DmdSig (DmdType env (map zapUsedOnceDemand ds))  data KillFlags = KillFlags     { kf_abs         :: Bool@@ -2569,11 +2574,11 @@ seqDemandList = foldr (seq . seqDemand) ()  seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()+seqDmdType (DmdType env ds) =+  seqDmdEnv env `seq` seqDemandList ds `seq` ()  seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemand env+seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs  seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty@@ -2682,17 +2687,20 @@   ppr ExnOrDiv = char 'x' -- for e(x)ception   ppr Dunno    = empty -instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]+instance Outputable DmdEnv where+  ppr (DE fvs div)+    = ppr div <> if null fv_elts then empty+                 else braces (fsep (map pp_elt fv_elts))     where       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv+      fv_elts = nonDetUFMToList fvs         -- It's OK to use nonDetUFMToList here because we only do it for         -- pretty printing +instance Outputable DmdType where+  ppr (DmdType fv ds)+    = hcat (map (angleBrackets . ppr) ds) <> ppr fv+ instance Outputable DmdSig where    ppr (DmdSig ty) = ppr ty @@ -2741,15 +2749,6 @@       2 -> Prod <$> get bh <*> get bh       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) -instance Binary DmdSig where-  put_ bh (DmdSig aa) = put_ bh aa-  get bh = DmdSig <$> get bh--instance Binary DmdType where-  -- Ignore DmdEnv when spitting out the DmdType-  put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr-  get bh = DmdType emptyDmdEnv <$> get bh <*> get bh- instance Binary Divergence where   put_ bh Dunno    = putByte bh 0   put_ bh ExnOrDiv = putByte bh 1@@ -2761,3 +2760,16 @@       1 -> return ExnOrDiv       2 -> return Diverges       _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))++instance Binary DmdEnv where+  -- Ignore VarEnv when spitting out the DmdType+  put_ bh (DE _ d) = put_ bh d+  get bh = DE emptyVarEnv <$> get bh++instance Binary DmdType where+  put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds+  get bh = DmdType <$> get bh <*> get bh++instance Binary DmdSig where+  put_ bh (DmdSig aa) = put_ bh aa+  get bh = DmdSig <$> get bh

@@ -598,6 +598,8 @@   GhcDiagnosticCode "EmptyStmtsGroupInDoNotation"                   = 82311   GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation"                = 19442 +  GhcDiagnosticCode "TcRnCannotDefaultConcrete"                     = 52083+   -- To generate new random numbers:   --  https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain   --

@@ -697,6 +697,8 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id +-- | This function counts all arguments post-unarisation, which includes+-- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) 

@@ -369,6 +369,7 @@         --         -- See documentation of the getters for what these packed fields mean.         lfInfo          :: !(Maybe LambdaFormInfo),+        -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure          -- See documentation of the getters for what these packed fields mean.         tagSig          :: !(Maybe TagSig)@@ -434,7 +435,7 @@ oneShotInfo = bitfieldGetOneShotInfo . bitfield  -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments--- this 'Id' has to be applied to before it doesn any meaningful work.+-- this 'Id' has to be applied to before it does any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield 

@@ -1000,8 +1000,9 @@    take apart a case scrutinisation on, or arg occurrence of, e.g.,    `RUBBISH[TupleRep[IntRep,DoubleRep]]` (which may stand in for `(# Int#, Double# #)`)    into its sub-parts `RUBBISH[IntRep]` and `RUBBISH[DoubleRep]`, similar to-   unboxed tuples. `RUBBISH[VoidRep]` is erased.-   See 'unariseRubbish_maybe' and also Note [Post-unarisation invariants].+   unboxed tuples.++   See 'unariseLiteral_maybe' and also Note [Post-unarisation invariants].  4. Cmm: We translate 'LitRubbish' to their actual rubbish value in 'cgLit'.    The particulars are boring, and only matter when debugging illicit use of

@@ -602,8 +602,10 @@   = pprPanic "kindPrimRep" (ppr ki)  -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that--- it encodes. See also Note [Getting from RuntimeRep to PrimRep]--- The [PrimRep] is the final runtime representation /after/ unarisation+-- it encodes. See also Note [Getting from RuntimeRep to PrimRep].+-- The @[PrimRep]@ is the final runtime representation /after/ unarisation.+--+-- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty   | Just rr_ty' <- coreView rr_ty@@ -615,9 +617,11 @@   = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty)  -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that--- it encodes. See also Note [Getting from RuntimeRep to PrimRep]--- The [PrimRep] is the final runtime representation /after/ unarisation--- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.+-- it encodes. See also Note [Getting from RuntimeRep to PrimRep].+-- The @[PrimRep]@ is the final runtime representation /after/ unarisation+-- and does not contain VoidRep.+--+-- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] runtimeRepPrimRep_maybe rr_ty   | Just rr_ty' <- coreView rr_ty

@@ -1211,13 +1211,13 @@ putBS bh bs =   BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do     put_ bh l-    putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)  getBS :: BinHandle -> IO ByteString getBS bh = do   l <- get bh :: IO Int   BS.create l $ \dest -> do-    getPrim bh l (\src -> BS.memcpy dest src l)+    getPrim bh l (\src -> copyBytes dest src l)  instance Binary ByteString where   put_ bh f = putBS bh f

@@ -6,18 +6,19 @@     , initTmpFs     , forkTmpFsFrom     , mergeTmpFsInto-    , FilesToClean(..)-    , emptyFilesToClean+    , PathsToClean(..)+    , emptyPathsToClean     , TempFileLifetime(..)     , TempDir (..)     , cleanTempDirs     , cleanTempFiles     , cleanCurrentModuleTempFiles+    , keepCurrentModuleTempFiles     , addFilesToClean     , changeTempFilesLifetime     , newTempName     , newTempLibName-    , newTempDir+    , newTempSubDir     , withSystemTempDirectory     , withTempDirectory     )@@ -63,25 +64,29 @@       --       -- Shared with forked TmpFs. -  , tmp_files_to_clean :: IORef FilesToClean+  , tmp_files_to_clean :: IORef PathsToClean       -- ^ Files to clean (per session or per module)       --       -- Not shared with forked TmpFs.+  , tmp_subdirs_to_clean :: IORef PathsToClean+      -- ^ Subdirs to clean (per session or per module)+      --+      -- Not shared with forked TmpFs.   } --- | A collection of files that must be deleted before ghc exits.-data FilesToClean = FilesToClean-    { ftcGhcSession :: !(Set FilePath)-        -- ^ Files that will be deleted at the end of runGhc(T)+-- | A collection of paths that must be deleted before ghc exits.+data PathsToClean = PathsToClean+    { ptcGhcSession :: !(Set FilePath)+        -- ^ Paths that will be deleted at the end of runGhc(T) -    , ftcCurrentModule :: !(Set FilePath)-        -- ^ Files that will be deleted the next time+    , ptcCurrentModule :: !(Set FilePath)+        -- ^ Paths that will be deleted the next time         -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of         -- the session.     }  -- | Used when a temp file is created. This determines which component Set of--- FilesToClean will get the temp file+-- PathsToClean will get the temp file data TempFileLifetime   = TFL_CurrentModule   -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the@@ -93,38 +98,45 @@  newtype TempDir = TempDir FilePath --- | An empty FilesToClean-emptyFilesToClean :: FilesToClean-emptyFilesToClean = FilesToClean Set.empty Set.empty+-- | An empty PathsToClean+emptyPathsToClean :: PathsToClean+emptyPathsToClean = PathsToClean Set.empty Set.empty --- | Merge two FilesToClean-mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean-mergeFilesToClean x y = FilesToClean-    { ftcGhcSession    = Set.union (ftcGhcSession x) (ftcGhcSession y)-    , ftcCurrentModule = Set.union (ftcCurrentModule x) (ftcCurrentModule y)+-- | Merge two PathsToClean+mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean+mergePathsToClean x y = PathsToClean+    { ptcGhcSession    = Set.union (ptcGhcSession x) (ptcGhcSession y)+    , ptcCurrentModule = Set.union (ptcCurrentModule x) (ptcCurrentModule y)     }  -- | Initialise an empty TmpFs initTmpFs :: IO TmpFs initTmpFs = do-    files <- newIORef emptyFilesToClean-    dirs  <- newIORef Map.empty-    next  <- newIORef 0+    files   <- newIORef emptyPathsToClean+    subdirs <- newIORef emptyPathsToClean+    dirs    <- newIORef Map.empty+    next    <- newIORef 0     return $ TmpFs-        { tmp_files_to_clean = files-        , tmp_dirs_to_clean  = dirs-        , tmp_next_suffix    = next+        { tmp_files_to_clean   = files+        , tmp_subdirs_to_clean = subdirs+        , tmp_dirs_to_clean    = dirs+        , tmp_next_suffix      = next         }  -- | Initialise an empty TmpFs sharing unique numbers and per-process temporary -- directories with the given TmpFs+--+-- It's not safe to use the subdirs created by the original TmpFs with the+-- forked one. Use @newTempSubDir@ to create new subdirs instead. forkTmpFsFrom :: TmpFs -> IO TmpFs forkTmpFsFrom old = do-    files <- newIORef emptyFilesToClean+    files <- newIORef emptyPathsToClean+    subdirs <- newIORef emptyPathsToClean     return $ TmpFs-        { tmp_files_to_clean = files-        , tmp_dirs_to_clean  = tmp_dirs_to_clean old-        , tmp_next_suffix    = tmp_next_suffix old+        { tmp_files_to_clean   = files+        , tmp_subdirs_to_clean = subdirs+        , tmp_dirs_to_clean    = tmp_dirs_to_clean old+        , tmp_next_suffix      = tmp_next_suffix old         }  -- | Merge the first TmpFs into the second.@@ -132,9 +144,12 @@ -- The first TmpFs is returned emptied. mergeTmpFsInto :: TmpFs -> TmpFs -> IO () mergeTmpFsInto src dst = do-    src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s))-    atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ()))+    src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyPathsToClean, s))+    src_subdirs <- atomicModifyIORef' (tmp_subdirs_to_clean src) (\s -> (emptyPathsToClean, s))+    atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergePathsToClean src_files s, ()))+    atomicModifyIORef' (tmp_subdirs_to_clean dst) (\s -> (mergePathsToClean src_subdirs s, ())) + cleanTempDirs :: Logger -> TmpFs -> IO () cleanTempDirs logger tmpfs    = mask_@@ -142,64 +157,104 @@         ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)         removeTmpDirs logger (Map.elems ds) --- | Delete all files in @tmp_files_to_clean@.+-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@. cleanTempFiles :: Logger -> TmpFs -> IO () cleanTempFiles logger tmpfs    = mask_-   $ do let ref = tmp_files_to_clean tmpfs-        to_delete <- atomicModifyIORef' ref $-            \FilesToClean-                { ftcCurrentModule = cm_files-                , ftcGhcSession = gs_files-                } -> ( emptyFilesToClean-                     , Set.toList cm_files ++ Set.toList gs_files)-        removeTmpFiles logger to_delete+   $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs)+        removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs)+  where+    removeWith remove ref = do+      to_delete <- atomicModifyIORef' ref $+        \PathsToClean+            { ptcCurrentModule = cm_paths+            , ptcGhcSession = gs_paths+            } -> ( emptyPathsToClean+                  , Set.toList cm_paths ++ Set.toList gs_paths)+      remove to_delete --- | Delete all files in @tmp_files_to_clean@. That have lifetime--- TFL_CurrentModule.+-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@+-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is+-- used in an OPTIONS_GHC pragma.+-- This function removes the temporary file from the TmpFs so we no longer remove+-- it at the env when cleanTempFiles is called.+keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()+keepCurrentModuleTempFiles logger tmpfs+   = mask_+   $ do to_keep_files <- keep  (tmp_files_to_clean tmpfs)+        to_keep_subdirs <- keep  (tmp_subdirs_to_clean tmpfs)+        -- Remove any folders which contain any files we want to keep from the+        -- directories we are tracking. A new temporary directory will be created+        -- the next time a temporary file is needed (by perhaps another module).+        keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs)+  where+    keepDirs keeps ref = do+      let keep_dirs = Set.fromList (map takeDirectory keeps)+      atomicModifyIORef' ref  $ \m -> (Map.filter (\fp -> fp `Set.notMember` keep_dirs) m, ())++    keep ref = do+        to_keep <- atomicModifyIORef' ref $+            \ptc@PathsToClean{ptcCurrentModule = cm_paths} ->+                (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths)+        debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep))+        return to_keep++-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@+-- That have lifetime TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO () cleanCurrentModuleTempFiles logger tmpfs    = mask_-   $ do let ref = tmp_files_to_clean tmpfs+   $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs)+        removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs)+  where+    removeWith remove ref = do         to_delete <- atomicModifyIORef' ref $-            \ftc@FilesToClean{ftcCurrentModule = cm_files} ->-                (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)-        removeTmpFiles logger to_delete+            \ptc@PathsToClean{ptcCurrentModule = cm_paths} ->+                (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths)+        remove to_delete  -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. -- If any of new_files are already tracked, they will have their lifetime -- updated. addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()-addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $-  \FilesToClean-    { ftcCurrentModule = cm_files-    , ftcGhcSession = gs_files+addFilesToClean tmpfs lifetime new_files =+  addToClean (tmp_files_to_clean tmpfs) lifetime new_files++addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()+addSubdirsToClean tmpfs lifetime new_subdirs =+  addToClean (tmp_subdirs_to_clean tmpfs) lifetime new_subdirs++addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO ()+addToClean ref lifetime new_filepaths = modifyIORef' ref $+  \PathsToClean+    { ptcCurrentModule = cm_paths+    , ptcGhcSession = gs_paths     } -> case lifetime of-      TFL_CurrentModule -> FilesToClean-        { ftcCurrentModule = cm_files `Set.union` new_files_set-        , ftcGhcSession = gs_files `Set.difference` new_files_set+      TFL_CurrentModule -> PathsToClean+        { ptcCurrentModule = cm_paths `Set.union` new_filepaths_set+        , ptcGhcSession = gs_paths `Set.difference` new_filepaths_set         }-      TFL_GhcSession -> FilesToClean-        { ftcCurrentModule = cm_files `Set.difference` new_files_set-        , ftcGhcSession = gs_files `Set.union` new_files_set+      TFL_GhcSession -> PathsToClean+        { ptcCurrentModule = cm_paths `Set.difference` new_filepaths_set+        , ptcGhcSession = gs_paths `Set.union` new_filepaths_set         }   where-    new_files_set = Set.fromList new_files+    new_filepaths_set = Set.fromList new_filepaths  -- | Update the lifetime of files already being tracked. If any files are -- not being tracked they will be discarded. changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () changeTempFilesLifetime tmpfs lifetime files = do-  FilesToClean-    { ftcCurrentModule = cm_files-    , ftcGhcSession = gs_files+  PathsToClean+    { ptcCurrentModule = cm_paths+    , ptcGhcSession = gs_paths     } <- readIORef (tmp_files_to_clean tmpfs)   let old_set = case lifetime of-        TFL_CurrentModule -> gs_files-        TFL_GhcSession -> cm_files+        TFL_CurrentModule -> gs_paths+        TFL_GhcSession -> cm_paths       existing_files = [f | f <- files, f `Set.member` old_set]   addFilesToClean tmpfs lifetime existing_files @@ -224,20 +279,32 @@                         addFilesToClean tmpfs lifetime [filename]                         return filename -newTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath-newTempDir logger tmpfs tmp_dir+-- | Create a new temporary subdirectory that doesn't already exist+-- The temporary subdirectory is automatically removed at the end of the+-- GHC session, but its contents aren't. Make sure to leave the directory+-- empty before the end of the session, either by removing content+-- directly or by using @addFilesToClean@.+--+-- If the created subdirectory is not empty, it will not be removed (along+-- with its parent temporary directory) and a warning message will be+-- printed at verbosity 2 and higher.+newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath+newTempSubDir logger tmpfs tmp_dir   = do d <- getTempDir logger tmpfs tmp_dir        findTempDir (d </> "ghc_")   where     findTempDir :: FilePath -> IO FilePath     findTempDir prefix       = do n <- newTempSuffix tmpfs-           let filename = prefix ++ show n-           b <- doesDirectoryExist filename+           let name = prefix ++ show n+           b <- doesDirectoryExist name            if b then findTempDir prefix-                else do createDirectory filename-                        -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename-                        return filename+                else (do+                  createDirectory name+                  addSubdirsToClean tmpfs TFL_GhcSession [name]+                  return name)+            `Exception.catchIO` \e -> if isAlreadyExistsError e+                  then findTempDir prefix else ioError e  newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix   -> IO (FilePath, FilePath, String)@@ -337,6 +404,12 @@         act      (non_deletees, deletees) = partition isHaskellUserSrcFilename fs++removeTmpSubdirs :: Logger -> [FilePath] -> IO ()+removeTmpSubdirs logger fs+  = traceCmd logger "Deleting temp subdirs"+             ("Deleting: " ++ unwords fs)+             (mapM_ (removeWith logger removeDirectory) fs)  removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO`

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