ghc-lib-parser 9.6.1.20230312 → 9.6.2.20230523

raw patch · 28 files changed

+596/−320 lines, 28 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• compiler/Bytecodes.h +0/−2
• compiler/GHC/Core.hs +44/−18
• compiler/GHC/Core/Coercion.hs +12/−3
• compiler/GHC/Core/Opt/Arity.hs +9/−2
• compiler/GHC/Core/Opt/OccurAnal.hs +11/−0
• compiler/GHC/Core/Opt/Simplify/Env.hs +1/−1
• compiler/GHC/Core/Opt/Simplify/Iteration.hs +172/−141
• compiler/GHC/Core/Opt/Simplify/Utils.hs +5/−2
• compiler/GHC/Core/Rules.hs +13/−7
• compiler/GHC/Core/Type.hs +1/−1
• compiler/GHC/Core/Unify.hs +113/−27
• compiler/GHC/Core/Utils.hs +2/−2
• compiler/GHC/Platform.hs +1/−0
• compiler/GHC/Tc/Utils/TcType.hs +34/−19
• compiler/GHC/Types/Id.hs +8/−6
• compiler/GHC/Types/Id/Make.hs +139/−60
• compiler/ghc.cabal +4/−4
• ghc-lib-parser.cabal +1/−1
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +7/−7
• ghc/ghc-bin.cabal +4/−4
• libraries/ghc-boot-th/ghc-boot-th.cabal +1/−1
• libraries/ghc-boot/GHC/Platform/ArchOS.hs +2/−0
• libraries/ghc-boot/ghc-boot.cabal +2/−2
• libraries/ghc-heap/ghc-heap.cabal +1/−1
• libraries/ghci/GHCi/Message.hs +1/−1
• libraries/ghci/ghci.cabal +3/−3
• libraries/template-haskell/template-haskell.cabal +1/−1

@@ -34,7 +34,6 @@ #define bci_PUSH16_W                    9 #define bci_PUSH32_W                    10 #define bci_PUSH_G                      11-#define bci_PUSH_ALTS                   12 #define bci_PUSH_ALTS_P                 13 #define bci_PUSH_ALTS_N                 14 #define bci_PUSH_ALTS_F                 15@@ -81,7 +80,6 @@ #define bci_CCALL                       56 #define bci_SWIZZLE                     57 #define bci_ENTER                       58-#define bci_RETURN                      59 #define bci_RETURN_P                    60 #define bci_RETURN_N                    61 #define bci_RETURN_F                    62

@@ -1301,16 +1301,19 @@         df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,     }                           -- in positional order -  | CoreUnfolding {             -- An unfolding for an Id with no pragma,-                                -- or perhaps a NOINLINE pragma-                                -- (For NOINLINE, the phase, if any, is in the-                                -- InlinePragInfo for this Id.)-        uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct-        uf_src        :: UnfoldingSource, -- Where the unfolding came from-        uf_is_top     :: Bool,          -- True <=> top level binding-        uf_cache      :: UnfoldingCache,        -- Cache of flags computable from the expr-                                                -- See Note [Tying the 'CoreUnfolding' knot]-        uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.+  | CoreUnfolding { -- An unfolding for an Id with no pragma,+                    -- or perhaps a NOINLINE pragma+                    -- (For NOINLINE, the phase, if any, is in the+                    -- InlinePragInfo for this Id.)+        uf_tmpl     :: CoreExpr,         -- The unfolding itself (aka "template")+                                         -- Always occ-analysed;+                                         -- See Note [OccInfo in unfoldings and rules]++        uf_src      :: UnfoldingSource,  -- Where the unfolding came from+        uf_is_top   :: Bool,             -- True <=> top level binding+        uf_cache    :: UnfoldingCache,   -- Cache of flags computable from the expr+                                         -- See Note [Tying the 'CoreUnfolding' knot]+        uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.     }   -- ^ An unfolding with redundant cached information. Parameters:   --@@ -1638,14 +1641,37 @@  Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In unfoldings and rules, we guarantee that the template is occ-analysed,-so that the occurrence info on the binders is correct.  This is important,-because the Simplifier does not re-analyse the template when using it. If-the occurrence info is wrong-  - We may get more simplifier iterations than necessary, because-    once-occ info isn't there-  - More seriously, we may get an infinite loop if there's a Rec-    without a loop breaker marked+In unfoldings and rules, we guarantee that the template is occ-analysed, so+that the occurrence info on the binders is correct. That way, when the+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.+(The Simplifier is designed to simplify occ-analysed expressions.)++Given this decision it's vital that we do *always* do it.++* If we don't, we may get more simplifier iterations than necessary,+  because once-occ info isn't there++* More seriously, we may get an infinite loop if there's a Rec without a+  loop breaker marked.++* Or we may get code that mentions variables not in scope: #22761+  e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3+  Then the pre-simplifier occ-anal will occ-anal the unfolding+  (redundantly perhaps, but we need its free vars); this will not report+  the use of `p`; so p's binding will be discarded, and yet `p` is still+  mentioned.++  Better to occ-anal the unfolding at birth, which will drop the+  z-binding as dead code.  (Remember, it's the occurrence analyser that+  drops dead code.)++* Another example is #8892:+    \x -> letrec { f = ...g...; g* = f } in body+  where g* is (for some strange reason) the loop breaker.  If we don't+  occ-anal it when reading it in, we won't mark g as a loop breaker, and we+  may inline g entirely in body, dropping its binding, and leaving the+  occurrence in f out of scope. This happened in #8892, where the unfolding+  in question was a DFun unfolding.   ************************************************************************

@@ -1355,7 +1355,7 @@ -- | Converts a coercion to be nominal, if possible. -- See Note [Role twiddling functions] setNominalRole_maybe :: Role -- of input coercion-                     -> Coercion -> Maybe Coercion+                     -> Coercion -> Maybe CoercionN setNominalRole_maybe r co   | r == Nominal = Just co   | otherwise = setNominalRole_maybe_helper co@@ -1380,10 +1380,19 @@       = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2     setNominalRole_maybe_helper (ForAllCo tv kind_co co)       = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (SelCo n co)+    setNominalRole_maybe_helper (SelCo cs co) =       -- NB, this case recurses via setNominalRole_maybe, not       -- setNominalRole_maybe_helper!-      = SelCo n <$> setNominalRole_maybe (coercionRole co) co+      case cs of+        SelTyCon n _r ->+          -- Remember to update the role in SelTyCon to nominal;+          -- not doing this caused #23362.+          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.+          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co+        SelFun fs ->+          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co+        SelForAll ->+          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)     setNominalRole_maybe_helper (InstCo co arg)       = InstCo <$> setNominalRole_maybe_helper co <*> pure arg     setNominalRole_maybe_helper (UnivCo prov _ co1 co2)

@@ -3085,8 +3085,15 @@   | need_args < 0   = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)   | otherwise-  = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args-         , ru_rhs = new_rhs }+  = rule { ru_bndrs = bndrs ++ new_bndrs+         , ru_args  = args ++ new_args+         , ru_rhs   = new_rhs }+  -- new_rhs really ought to be occ-analysed (see GHC.Core Note+  -- [OccInfo in unfoldings and rules]), but it makes a module loop to+  -- do so; it doesn't happen often; and it doesn't really matter if+  -- the outer binders have bogus occurrence info; and new_rhs won't+  -- have dead code if rhs didn't.+   where     need_args = join_arity - length args     (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs

@@ -2046,6 +2046,17 @@ empty.   This just saves a bit of allocation and reconstruction; not a big deal. +This fast path exposes a tricky cornder, though (#22761). Supose we have+    Unfolding = \x. let y = foo in x+1+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+the unfolding and produce /no/ occurrences of `foo` (since `y` is+dead).  But if we discard the occ-analysed syntax tree (which we do on+our fast path), and use the old one, we still /have/ an occurrence of+`foo` -- and that can lead to out-of-scope variables (#22761).++Solution: always keep occ-analysed trees in unfoldings and rules, so they+have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.+ Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an rhsCtxt for the RHS of a binding.  This tells the

@@ -1065,7 +1065,7 @@     -- See Note [Bangs in the Simplifier]     !id1  = uniqAway in_scope old_id     !id2  = substIdType env id1-    !id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding+    !id3  = zapFragileIdInfo id2      -- Zaps rules, worker-info, unfolding                                       -- and fragile OccInfo     !new_id = adjust_type id3 

@@ -318,14 +318,14 @@               -> TopLevelFlag -> RecFlag               -> InId -> OutId          -- Binder, both pre-and post simpl                                         -- Not a JoinId-                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- The OutId has IdInfo (notably RULES),+                                        -- except arity, unfolding                                         -- Ids only, no TyVars               -> InExpr -> SimplEnv     -- The RHS and its environment               -> SimplM (SimplFloats, SimplEnv) -- Precondition: the OutId is already in the InScopeSet of the incoming 'env' -- Precondition: not a JoinId -- Precondition: rhs obeys the let-can-float invariant--- NOT used for JoinIds simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se   = assert (isId bndr )     assertPpr (not (isJoinId bndr)) (ppr bndr) $@@ -397,48 +397,45 @@         ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }  ---------------------------simplNonRecX :: SimplEnv+simplAuxBind :: SimplEnv              -> InId            -- Old binder; not a JoinId              -> OutExpr         -- Simplified RHS              -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon.  It uses case-binding where necessary.+-- A specialised variant of completeBindX used to construct non-recursive+-- auxiliary bindings, notably in knownCon. --+-- The binder comes from a case expression (case binder or alternative)+-- and so does not have rules, inline pragmas etc.+-- -- Precondition: rhs satisfies the let-can-float invariant -simplNonRecX env bndr new_rhs-  | assertPpr (not (isJoinId bndr)) (ppr bndr) $+simplAuxBind env bndr new_rhs+  | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $     isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }   = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                         --  creating the binding c = (a,b)--  | Coercion co <- new_rhs-  = return (emptyFloats env, extendCvSubst env bndr co)+                                     --  creating the binding c = (a,b) +  -- The cases would be inlined unconditionally by completeBind:+  -- but it seems not uncommon, and avoids faff to do it here+  -- This is safe because it's only used for auxiliary bindings, which+  -- have no NOLINE pragmas, nor RULEs   | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...-    -- This case would ultimately land in postInlineUnconditionally-    -- but it seems not uncommon, and avoids a lot of faff to do it here-  = return (emptyFloats env-           , extendIdSubst env bndr (DoneEx new_rhs Nothing))+  = return ( emptyFloats env+           , case new_rhs of+                Coercion co -> extendCvSubst env bndr co+                _           -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )    | otherwise-  = do  { (env1, new_bndr)   <- simplBinder env bndr-        ; let is_strict = isStrictId new_bndr-              -- isStrictId: use new_bndr because the InId bndr might not have-              -- a fixed runtime representation, which isStrictId doesn't expect-              -- c.f. Note [Dark corner with representation polymorphism]--        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict-                                               new_bndr (emptyFloats env) new_rhs-              -- NB: it makes a surprisingly big difference (5% in compiler allocation-              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',-              -- because this is simplNonRecX, so bndr is not in scope in the RHS.+  = do  { -- ANF-ise the RHS+          let !occ_fs = getOccFS bndr+        ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs+        ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)+        ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats -        ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)-                                             (BC_Let NotTopLevel NonRecursive)+          -- Simplify the binder and complete the binding+        ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr+        ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)                                              bndr new_bndr rhs1-              -- Must pass env1 to completeBind in case simplBinder had to clone,-              -- and extended the substitution with [bndr :-> new_bndr]          ; return (rhs_floats `addFloats` bind_float, env2) } @@ -760,49 +757,54 @@ --            x = Just a -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0-  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0-        ; return (floats, rhs1) }+  | is_expandable = anfise rhs0+  | otherwise     = return (emptyLetFloats, rhs0)   where-    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)-    go n_val_args (Cast rhs co)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Cast rhs' co) }-    go n_val_args (App fun (Type ty))-        = do { (is_exp, floats, rhs') <- go n_val_args fun-             ; return (is_exp, floats, App rhs' (Type ty)) }-    go n_val_args (App fun arg)-        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; if is_exp-               then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg-                       ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }-               else return (False, emptyLetFloats, App fun arg)-             }-    go n_val_args (Var fun)-        = return (is_exp, emptyLetFloats, Var fun)-        where-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP-                        -- See Note [CONLIKE pragma] in GHC.Types.Basic-                        -- The definition of is_exp should match that in-                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'+    -- We can' use exprIsExpandable because the WHOLE POINT is that+    -- we want to treat (K <big>) as expandable, because we are just+    -- about "anfise" the <big> expression.  exprIsExpandable would+    -- just say no!+    is_expandable = go rhs0 0+       where+         go (Var fun) n_val_args       = isExpandableApp fun n_val_args+         go (App fun arg) n_val_args+           | isTypeArg arg             = go fun n_val_args+           | otherwise                 = go fun (n_val_args + 1)+         go (Cast rhs _)  n_val_args   = go rhs n_val_args+         go (Tick _ rhs)  n_val_args   = go rhs n_val_args+         go _             _            = False -    go n_val_args (Tick t rhs)+    anfise :: OutExpr -> SimplM (LetFloats, OutExpr)+    anfise (Cast rhs co)+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Cast rhs' co) }+    anfise (App fun (Type ty))+        = do { (floats, rhs') <- anfise fun+             ; return (floats, App rhs' (Type ty)) }+    anfise (App fun arg)+        = do { (floats1, fun') <- anfise fun+             ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+             ; return (floats1 `addLetFlts` floats2, App fun' arg') }+    anfise (Var fun)+        = return (emptyLetFloats, Var fun)++    anfise (Tick t rhs)         -- We want to be able to float bindings past this         -- tick. Non-scoping ticks don't care.         | tickishScoped t == NoScope-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Tick t rhs') }+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Tick t rhs') }          -- On the other hand, for scoping ticks we need to be able to         -- copy them on the floats, which in turn is only allowed if         -- we can obtain non-counting ticks.         | (not (tickishCounts t) || tickishCanSplit t)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs+        = do { (floats, rhs') <- anfise rhs              ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)                    floats' = mapLetFloats floats tickIt-             ; return (is_exp, floats', Tick t rhs') }+             ; return (floats', Tick t rhs') } -    go _ other-        = return (False, emptyLetFloats, other)+    anfise other = return (emptyLetFloats, other)  makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })@@ -1243,7 +1245,7 @@    | otherwise   = {-#SCC "simplNonRecE" #-}-    simplNonRecE env False bndr (rhs, env) body cont+    simplNonRecE env FromLet bndr (rhs, env) body cont  {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1504,8 +1506,9 @@       StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }         -> rebuildCall env (addValArgTo fun expr fun_ty ) cont -      StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }-        -> completeBindX (se `setInScopeFromE` env) b expr body cont+      StrictBind { sc_bndr = b, sc_body = body, sc_env = se+                 , sc_cont = cont, sc_from = from_what }+        -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont        ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}         -> rebuild env (App expr (Type ty)) cont@@ -1517,26 +1520,49 @@               ; rebuild env (App expr arg') cont }  completeBindX :: SimplEnv+              -> FromWhat               -> InId -> OutExpr   -- Bind this Id to this (simplified) expression                                    -- (the let-can-float invariant may not be satisfied)-              -> InExpr  -- In this lambda+              -> InExpr            -- In this body               -> SimplCont         -- Consumed by this continuation               -> SimplM (SimplFloats, OutExpr)-completeBindX env bndr rhs body cont-  | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant-  = do { (env1, bndr1) <- simplNonRecBndr env bndr-       ; (floats, expr') <- simplLam env1 body cont+completeBindX env from_what bndr rhs body cont+  | FromBeta arg_ty <- from_what+  , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant+  = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules+       ; (floats, expr') <- simplNonRecBody env1 from_what body cont        -- Do not float floats past the Case binder below        ; let expr'' = wrapFloats floats expr'-       ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+             case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']        ; return (emptyFloats env, case_expr) } -  | otherwise-  = do  { (floats1, env') <- simplNonRecX env bndr rhs-        ; (floats2, expr') <- simplLam env' body cont-        ; return (floats1 `addFloats` floats2, expr') }+  | otherwise -- Make a let-binding+  = do  { (env1, bndr1) <- simplNonRecBndr env bndr+        ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) +        ; let is_strict = isStrictId bndr2+              -- isStrictId: use simplified binder because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism] +        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               bndr2 (emptyFloats env) rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is simplNonRecX, so bndr is not in scope in the RHS.++        ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)+                                             (BC_Let NotTopLevel NonRecursive)+                                             bndr bndr2 rhs1+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        -- Simplify the body+        ; (body_floats, body') <- simplNonRecBody env2 from_what body cont++        ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats+        ; return ( all_floats, body' ) }+ {- ************************************************************************ *                                                                      *@@ -1673,6 +1699,14 @@ ************************************************************************ -} +simplNonRecBody :: SimplEnv -> FromWhat+                -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+simplNonRecBody env from_what body cont+  = case from_what of+      FromLet     -> simplExprF env body cont+      FromBeta {} -> simplLam   env body cont+ simplLam :: SimplEnv -> InExpr -> SimplCont          -> SimplM (SimplFloats, OutExpr) @@ -1689,16 +1723,25 @@  -- Value beta-reduction simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                    , sc_cont = cont, sc_dup = dup })-  | isSimplified dup  -- Don't re-simplify if we've simplified it once-                      -- See Note [Avoiding exponential behaviour]+                                    , sc_cont = cont, sc_dup = dup+                                    , sc_hole_ty = fun_ty})   = do { tick (BetaReduction bndr)-       ; completeBindX env bndr arg body cont }+       ; let arg_ty = funArgTy fun_ty+       ; if | isSimplified dup  -- Don't re-simplify if we've simplified it once+                                -- Including don't preInlineUnconditionally+                                -- See Note [Avoiding exponential behaviour]+            -> completeBindX env (FromBeta arg_ty) bndr arg body cont -  | otherwise         -- See Note [Avoiding exponential behaviour]-  = do { tick (BetaReduction bndr)-       ; simplNonRecE env True bndr (arg, arg_se) body cont }+            | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se+            , not (needsCaseBinding arg_ty arg)+              -- Ok to test arg::InExpr in needsCaseBinding because+              -- exprOkForSpeculation is stable under simplification+            -> do { tick (PreInlineUnconditionally bndr)+                  ; simplLam env' body cont } +            | otherwise+            -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }+ -- Discard a non-counting tick on a lambda.  This may change the -- cost attribution slightly (moving the allocation of the -- lambda elsewhere), but we don't care: optimisation changes@@ -1729,8 +1772,7 @@  ------------------ simplNonRecE :: SimplEnv-             -> Bool                    -- True  <=> from a lambda-                                        -- False <=> from a let+             -> FromWhat              -> InId                    -- The binder, always an Id                                         -- Never a join point              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)@@ -1739,57 +1781,49 @@              -> SimplM (SimplFloats, OutExpr)  -- simplNonRecE is used for---  * non-top-level non-recursive non-join-point lets in expressions---  * beta reduction+--  * from=FromLet:  a non-top-level non-recursive non-join-point let-expression+--  * from=FromBeta: a binding arising from a beta reduction ----- simplNonRec env b (rhs, rhs_se) body k+-- simplNonRecE env b (rhs, rhs_se) body k --   = let env in --     cont< let b = rhs_se(rhs) in body > -- -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process. ----- from_lam=False => the RHS satisfies the let-can-float invariant+-- from_what=FromLet => the RHS satisfies the let-can-float invariant -- Otherwise it may or may not satisfy it. -simplNonRecE env from_lam bndr (rhs, rhs_se) body cont-  = assert (isId bndr && not (isJoinId bndr) ) $-    do { (env1, bndr1) <- simplNonRecBndr env bndr-       ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs-         -- See Note [Dark corner with representation polymorphism]-         -- If from_lam=False then needs_case_binding is False,-         -- because the binding started as a let, which must-         -- satisfy let-can-float+simplNonRecE env from_what bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) $+    is_strict_bind+  = -- Evaluate RHS strictly+    simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup }) -       ; if | from_lam && not needs_case_binding-              -- If not from_lam we are coming from a (NonRec bndr rhs) binding-              -- and preInlineUnconditionally has been done already;-              -- no need to repeat it.  But for lambdas we must be careful about-              -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk")-              -- We must not drop the (error "urk").-            , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-            -> do { tick (PreInlineUnconditionally bndr)-                  ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-                    simplLam env' body cont }+  | otherwise  -- Evaluate RHS lazily+  = do { (env1, bndr1)    <- simplNonRecBndr env bndr+       ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive+                                           bndr bndr2 rhs rhs_se+       ; (floats2, expr') <- simplNonRecBody env3 from_what body cont+       ; return (floats1 `addFloats` floats2, expr') } -             -- Deal with strict bindings-            |  isStrictId bndr1 && seCaseCase env-            || from_lam && needs_case_binding-               -- The important bit here is needs_case_binds; but no need to-               -- test it if from_lam is False because then needs_case_binding is False too-               -- NB: either way, the RHS may or may not satisfy let-can-float-               --     but that's ok for StrictBind.-            -> simplExprF (rhs_se `setInScopeFromE` env) rhs-                          (StrictBind { sc_bndr = bndr, sc_body = body-                                      , sc_env = env, sc_cont = cont, sc_dup = NoDup })+  where+    is_strict_bind = case from_what of+       FromBeta arg_ty | isUnliftedType arg_ty -> True+         -- If we are coming from a beta-reduction (FromBeta) we must+         -- establish the let-can-float invariant, so go via StrictBind+         -- If not, the invariant holds already, and it's optional.+         -- Using arg_ty: see Note [Dark corner with representation polymorphism]+         -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+         --      When we come to `x=arg` we myst choose lazy/strict correctly+         --      It's wrong to err in either directly -            -- Deal with lazy bindings-            | otherwise-            -> do { (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)-                  ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-                  ; (floats2, expr') <- simplLam env3 body cont-                  ; return (floats1 `addFloats` floats2, expr') } }+       _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr) + ------------------ simplRecE :: SimplEnv           -> [(InId, InExpr)]@@ -1834,7 +1868,7 @@ One way in which we can get exponential behaviour is if we simplify a big expression, and then re-simplify it -- and then this happens in a deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why simplNonRecX does not try+an expression (#13379).  That is why simplNonRecX does not try preInlineUnconditionally (unlike simplNonRecE).  Example:@@ -2617,15 +2651,10 @@ of the rule firing to simplify it, so occurrence analysis is at most a constant factor. -Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.-+Note, however, that the rule RHS is /already/ occ-analysed; see+Note [OccInfo in unfoldings and rules] in GHC.Core.  There is something+unsatisfactory about doing it twice; but the rule RHS is usually very+small, and this is simple.  Note [Optimising tagToEnum#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2929,7 +2958,7 @@   where     simple_rhs env wfloats case_bndr_rhs bs rhs =       assert (null bs) $-      do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs+      do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs              -- scrut is a constructor application,              -- hence satisfies let-can-float invariant          ; (floats2, expr') <- simplExprF env' rhs cont@@ -2996,7 +3025,7 @@   | all_dead_bndrs   , doCaseToLet scrut case_bndr   = do { tick (CaseElim case_bndr)-       ; (floats1, env') <- simplNonRecX env case_bndr scrut+       ; (floats1, env')  <- simplAuxBind env case_bndr scrut        ; (floats2, expr') <- simplExprF env' rhs cont        ; return (floats1 `addFloats` floats2, expr') } @@ -3484,12 +3513,11 @@     bind_args env' (b:bs') (arg : args)       = assert (isId b) $         do { let b' = zap_occ b-             -- Note that the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplNonRecX may therefore discard-             -- it via postInlineUnconditionally.+             -- zap_occ: the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplAuxBind may therefore discard it.              -- Nevertheless we must keep it if the case-binder is alive,              -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let-can-float invariant+           ; (floats1, env2) <- simplAuxBind env' b' arg  -- arg satisfies let-can-float invariant            ; (floats2, env3)  <- bind_args env2 bs' args            ; return (floats1 `addFloats` floats2, env3) } @@ -3515,7 +3543,7 @@                                  ; let con_app = Var (dataConWorkId dc)                                                  `mkTyApps` dc_ty_args                                                  `mkApps`   dc_args-                                 ; simplNonRecX env bndr con_app }+                                 ; simplAuxBind env bndr con_app }  ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont@@ -3622,15 +3650,15 @@         ; return (floats, TickIt t cont') }  mkDupableContWithDmds env _-     (StrictBind { sc_bndr = bndr, sc_body = body+     (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what                  , sc_env = se, sc_cont = cont}) -- See Note [Duplicating StrictBind] -- K[ let x = <> in b ]  -->   join j x = K[ b ] --                             j <>   = do { let sb_env = se `setInScopeFromE` env        ; (sb_env1, bndr')      <- simplBinder sb_env bndr-       ; (floats1, join_inner) <- simplLam sb_env1 body cont-          -- No need to use mkDupableCont before simplLam; we+       ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont+          -- No need to use mkDupableCont before simplNonRecBody; we           -- use cont once here, and then share the result if necessary         ; let join_body = wrapFloats floats1 join_inner@@ -3758,6 +3786,7 @@            , StrictBind { sc_bndr = arg_bndr                         , sc_body = join_rhs                         , sc_env  = zapSubstEnv env+                        , sc_from = FromLet                           -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils                         , sc_dup  = OkToDup                         , sc_cont = mkBoringStop res_ty } )@@ -4431,7 +4460,9 @@            ; return (rule { ru_bndrs = bndrs'                           , ru_fn    = fn_name'                           , ru_args  = args'-                          , ru_rhs   = rhs' }) }+                          , ru_rhs   = occurAnalyseExpr rhs' }) }+                            -- Remember to occ-analyse, to drop dead code.+                            -- See Note [OccInfo in unfoldings and rules] in GHC.Core  {- Note [Simplifying the RHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -21,7 +21,7 @@         BindContext(..), bindContextLevel,          -- The continuation type-        SimplCont(..), DupFlag(..), StaticEnv,+        SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,         isSimplified, contIsStop,         contIsDupable, contResultType, contHoleType, contHoleScaling,         contIsTrivial, contArgs, contIsRhs,@@ -191,6 +191,7 @@                         --       or, equivalently,  = K[ (\x.b) e ]       { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]       , sc_bndr  :: InId+      , sc_from  :: FromWhat       , sc_body  :: InExpr       , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]       , sc_cont  :: SimplCont }@@ -212,6 +213,8 @@  type StaticEnv = SimplEnv       -- Just the static part is relevant +data FromWhat = FromLet | FromBeta OutType+ -- See Note [DupFlag invariants] data DupFlag = NoDup       -- Unsimplified, might be big              | Simplified  -- Simplified@@ -549,7 +552,7 @@  countValArgs :: SimplCont -> Int -- Count value arguments only-countValArgs (ApplyToTy  { sc_cont = cont }) = 1 + countValArgs cont+countValArgs (ApplyToTy  { sc_cont = cont }) = countValArgs cont countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont countValArgs (CastIt _ cont)                 = countValArgs cont countValArgs _                               = 0

@@ -62,6 +62,7 @@ import GHC.Core.Tidy     ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )  import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types    ( anyTypeOfKind )@@ -187,13 +188,18 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs-  = Rule { ru_name = name, ru_fn = fn, ru_act = act,-           ru_bndrs = bndrs, ru_args = args,-           ru_rhs = rhs,-           ru_rough = roughTopNames args,-           ru_origin = this_mod,-           ru_orphan = orph,-           ru_auto = is_auto, ru_local = is_local }+  = Rule { ru_name   = name+         , ru_act    = act+         , ru_fn     = fn+         , ru_bndrs  = bndrs+         , ru_args   = args+         , ru_rhs    = occurAnalyseExpr rhs+                       -- See Note [OccInfo in unfoldings and rules]+         , ru_rough  = roughTopNames args+         , ru_origin = this_mod+         , ru_orphan = orph+         , ru_auto   = is_auto+         , ru_local  = is_local }   where         -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv         -- A rule is an orphan only if none of the variables

@@ -1481,7 +1481,7 @@         -- c.f. #15473         pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) -applyTysX :: [TyVar] -> Type -> [Type] -> Type+applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type -- applyTysX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys

@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-}  {-# LANGUAGE DeriveFunctor #-} @@ -47,6 +47,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Exts( oneShot )+import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -994,6 +995,59 @@ (legitimately) have different numbers of arguments.  They are surelyApart, so we can report that without looking any further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+   type family F a :: Type -> Type+   type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+  Since F is injective, we can reduce this to Int ~ Char,+  therefore SurelyApart.++* F Int ~ F Char, where F is not injective+  Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+  Even though G is injective and the arguments to G are different,+  we cannot deduce apartness because the RHS is oversaturated.+  For example, G might be defined as+    G Type = Maybe Int+    G (Type -> Type) = Maybe+  So we return MaybeApart.++* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)+  F Int Bool ~ Maybe a          -- MaybeApart+  F Int Bool ~ a b              -- MaybeApart+  F Int Bool ~ Char -> Bool     -- MaybeApart+  An oversaturated type family can match an application,+  whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+  We cannot decompose a saturated, or under-saturated+  type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+  A saturated application.+  Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+  A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+  An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+  If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families. -}  -------------- unify_ty: the main workhorse -----------@@ -1035,32 +1089,64 @@   = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)  unify_ty env ty1 ty2 _kco-  | Just (tc1, tys1) <- mb_tc_app1-  , Just (tc2, tys2) <- mb_tc_app2++  -- Handle non-oversaturated type families first+  -- See Note [Unifying type applications]+  --+  -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T+  -- Note that both sides must not be oversaturated+  | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1+  , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2   , tc1 == tc2-  = if isInjectiveTyCon tc1 Nominal-    then unify_tys env tys1 tys2-    else do { let inj | isTypeFamilyTyCon tc1-                      = case tyConInjectivityInfo tc1 of-                               NotInjective -> repeat False-                               Injective bs -> bs-                      | otherwise-                      = repeat False+  = do { let inj = case tyConInjectivityInfo tc1 of+                          NotInjective -> repeat False+                          Injective bs -> bs -                  (inj_tys1, noninj_tys1) = partitionByList inj tys1-                  (inj_tys2, noninj_tys2) = partitionByList inj tys2+             (inj_tys1, noninj_tys1) = partitionByList inj tys1+             (inj_tys2, noninj_tys2) = partitionByList inj tys2 -            ; unify_tys env inj_tys1 inj_tys2-            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-              don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }+       ; unify_tys env inj_tys1 inj_tys2+       ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]+         don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } -  | isTyFamApp mb_tc_app1     -- A (not-over-saturated) type-family application-  = maybeApart MARTypeFamily  -- behaves like a type variable; might match+  | Just _ <- isSatTyFamApp mb_tc_app1  -- (C2) A (not-over-saturated) type-family application+  = maybeApart MARTypeFamily            -- behaves like a type variable; might match -  | isTyFamApp mb_tc_app2     -- A (not-over-saturated) type-family application-  , um_unif env               -- behaves like a type variable; might unify-  = maybeApart MARTypeFamily+  | Just _ <- isSatTyFamApp mb_tc_app2  -- (C2) A (not-over-saturated) type-family application+                                        -- behaves like a type variable; might unify+                                        -- but doesn't match (as in the TyVarTy case)+  = if um_unif env then maybeApart MARTypeFamily else surelyApart +  -- Handle oversaturated type families.+  --+  -- They can match an application (TyConApp/FunTy/AppTy), this is handled+  -- the same way as in the AppTy case below.+  --+  -- If there is no application, an oversaturated type family can only+  -- match a type variable or a saturated type family,+  -- both of which we handled earlier. So we can say surelyApart.+  | Just (tc1, _) <- mb_tc_app1+  , isTypeFamilyTyCon tc1+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  | Just (tc2, _) <- mb_tc_app2+  , isTypeFamilyTyCon tc2+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  -- At this point, neither tc1 nor tc2 can be a type family.+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2+  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+       ; unify_tys env tys1 tys2+       }+   -- TYPE and CONSTRAINT are not Apart   -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim   -- NB: at this point we know that the two TyCons do not match@@ -1160,16 +1246,16 @@       -- Possibly different saturations of a polykinded tycon       -- See Note [Polykinded tycon applications] -isTyFamApp :: Maybe (TyCon, [Type]) -> Bool--- True if we have a saturated or under-saturated type family application+isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application -- If it is /over/ saturated then we return False.  E.g. --     unify_ty (F a b) (c d)    where F has arity 1 -- we definitely want to decompose that type application! (#22647)-isTyFamApp (Just (tc, tys))-  =  not (isGenerativeTyCon tc Nominal)       -- Type family-ish+isSatTyFamApp tapp@(Just (tc, tys))+  |  isTypeFamilyTyCon tc   && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated-isTyFamApp Nothing-  = False+  = tapp+isSatTyFamApp _ = Nothing  --------------------------------- uVar :: UMEnv

@@ -515,8 +515,8 @@ -- | Tests whether we have to use a @case@ rather than @let@ binding for this -- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs =-  mightBeUnliftedType ty && not (exprOkForSpeculation rhs)+needsCaseBinding ty rhs+  = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)         -- Make a case expression instead of a let         -- These can arise either from the desugarer,         -- or from beta reductions: (\x.e) (x +# y)

@@ -207,6 +207,7 @@ osElfTarget OSAIX       = False osElfTarget OSHurd      = True osElfTarget OSWasi      = False+osElfTarget OSGhcjs     = False osElfTarget OSUnknown   = False  -- Defaulting to False is safe; it means don't rely on any  -- ELF-specific functionality.  It is important to have a default for

@@ -2387,22 +2387,32 @@ -}  +-- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'?+--+-- See Note [Paterson conditions] in GHC.Tc.Validity. data PatersonSizeFailure-  = PSF_TyFam TyCon     -- Type family-  | PSF_Size            -- Too many type constructors/variables-  | PSF_TyVar [TyVar]   -- These type variables appear more often than in instance head;-                        --   no duplicates in this list+  -- | Either side contains a type family.+  = PSF_TyFam TyCon+  -- | The size of the LHS is not strictly less than the size of the RHS.+  | PSF_Size+  -- | These type variables appear more often in the LHS than in the RHS.+  | PSF_TyVar [TyVar] -- ^  no duplicates in this list  -------------------------------------- -data PatersonSize    -- See Note [Paterson conditions] in GHC.Tc.Validity-  = PS_TyFam TyCon   -- Mentions a type family; infinite size+-- | The Paterson size of a given type, in the sense of+-- Note [Paterson conditions] in GHC.Tc.Validity+--+--   - after expanding synonyms,+--   - ignoring coercions (as they are not user written).+data PatersonSize+  -- | The type mentions a type family, so the size could be anything.+  = PS_TyFam TyCon -  | PS_Vanilla { ps_tvs :: [TyVar]  -- Free tyvars, including repetitions;-               , ps_size :: Int     -- Number of type constructors and variables+  -- | The type does not mention a type family.+  | PS_Vanilla { ps_tvs :: [TyVar]  -- ^ free tyvars, including repetitions;+               , ps_size :: Int     -- ^ number of type constructors and variables     }-  -- Always after expanding synonyms-  -- Always ignore coercions (not user written)   -- ToDo: ignore invisible arguments?  See Note [Invisible arguments and termination]  instance Outputable PatersonSize where@@ -2415,21 +2425,26 @@ pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 } pSizeOne  = PS_Vanilla { ps_tvs = [], ps_size = 1 } -ltPatersonSize :: PatersonSize    -- Size of constraint-               -> PatersonSize    -- Size of instance head; never PS_TyFam+-- | @ltPatersonSize ps1 ps2@ returns:+--+--  - @Nothing@ iff @ps1@ is definitely strictly smaller than @ps2@,+--  - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong.+ltPatersonSize :: PatersonSize+               -> PatersonSize                -> Maybe PatersonSizeFailure--- (ps1 `ltPatersonSize` ps2) returns---     Nothing iff ps1 is strictly smaller than p2---     Just ps_fail says what went wrong-ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc) ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 })                (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 })   | s1 >= s2                                = Just PSF_Size   | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs)   | otherwise                               = Nothing -- OK!-ltPatersonSize (PS_Vanilla {}) (PS_TyFam tc)-  = pprPanic "ltPSize" (ppr tc)-    -- Impossible because we never have a type family in an instance head+ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc)+ltPatersonSize _ (PS_TyFam tc) = Just (PSF_TyFam tc)+  -- NB: this last equation is never taken when checking instances, because+  -- type families are disallowed in instance heads.+  --+  -- However, this function is also used in the logic for solving superclass+  -- constraints (see Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance),+  -- in which case we might well hit this case (see e.g. T23171).  noMoreTyVars :: [TyVar]  -- Free vars (with repetitions) of the constraint C              -> [TyVar]  -- Free vars (with repetitions) of the head H

@@ -723,12 +723,14 @@ zapIdDmdSig :: Id -> Id zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id --- | This predicate says whether the 'Id' has a strict demand placed on it or--- has a type such that it can always be evaluated strictly (i.e an--- unlifted type, as of GHC 7.6).  We need to--- check separately whether the 'Id' has a so-called \"strict type\" because if--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict--- type, we still want @isStrictId id@ to be @True@.+-- | `isStrictId` says whether either+--   (a) the 'Id' has a strict demand placed on it or+--   (b) definitely has a \"strict type\", such that it can always be+--       evaluated strictly (i.e an unlifted type)+-- We need to check (b) as well as (a), because when the demand for the+-- given `id` hasn't been computed yet but `id` has a strict+-- type, we still want `isStrictId id` to be `True`.+-- Returns False if the type is levity polymorphic; False is always safe. isStrictId :: Id -> Bool isStrictId id   | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $

@@ -1048,8 +1048,7 @@         arg_ty' = case mb_co of                     { Just redn -> scaledSet arg_ty (reductionReducedType redn)                     ; Nothing   -> arg_ty }-  , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')-  , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'+  , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty'   = if bang_opt_unbox_disable bang_opts     then HsStrict True -- Not unpacking because of -O0                        -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon@@ -1324,69 +1323,95 @@ mkUbxSumAltTy [ty] = ty mkUbxSumAltTy tys  = mkTupleTy Unboxed tys -shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool+shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool -- True if we ought to unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves!-shouldUnpackTy bang_opts prag fam_envs ty-  | Just data_cons <- unpackable_type_datacons (scaledThing ty)-  = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons+shouldUnpackArgTy bang_opts prag fam_envs arg_ty+  | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)+  , all ok_con data_cons                -- Returns True only if we can't get a+                                        -- loop involving these data cons+  , should_unpack prag arg_ty data_cons -- ...hence the call to dataConArgUnpack in+                                        --    should_unpack won't loop+       -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff+  = True+   | otherwise   = False   where-    ok_con_args :: NameSet -> DataCon -> Bool-    ok_con_args dcs con-       | dc_name `elemNameSet` dcs-       = False-       | otherwise-       = all (ok_arg dcs')-             (dataConOrigArgTys con `zip` dataConSrcBangs con)-          -- NB: dataConSrcBangs gives the *user* request;-          -- We'd get a black hole if we used dataConImplBangs+    ok_con :: DataCon -> Bool      -- True <=> OK to unpack+    ok_con top_con                 -- False <=> not safe+      = ok_args emptyNameSet top_con        where-         dc_name = getName con-         dcs' = dcs `extendNameSet` dc_name+         top_con_name = getName top_con -    ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool-    ok_arg dcs (Scaled _ ty, bang)-      = not (attempt_unpack bang) || ok_ty dcs norm_ty-      where-        norm_ty = topNormaliseType fam_envs ty+         ok_args dcs con+           = all (ok_arg dcs) $+             (dataConOrigArgTys con `zip` dataConSrcBangs con)+             -- NB: dataConSrcBangs gives the *user* request;+             -- We'd get a black hole if we used dataConImplBangs -    ok_ty :: NameSet -> Type -> Bool-    ok_ty dcs ty-      | Just data_cons <- unpackable_type_datacons ty-      = all (ok_con_args dcs) data_cons-      | otherwise-      = True        -- NB True here, in contrast to False at top level+         ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool+         ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)+           | strict_field str_prag+           , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)+           , should_unpack_conservative unpack_prag data_cons  -- Wrinkle (W3)+           = all (ok_rec_con dcs) data_cons                    --  of Note [Recursive unboxing]+           | otherwise+           = True        -- NB True here, in contrast to False at top level -    attempt_unpack :: HsSrcBang -> Bool-    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)-      = bang_opt_strict_data bang_opts-    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)-      = True-    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)-      = True  -- Be conservative-    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)-      = bang_opt_strict_data bang_opts -- Be conservative-    attempt_unpack _ = False+         -- See Note [Recursive unboxing]+         --   * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)+         --   * For the "at the root" comments see Wrinkle (W2)+         ok_rec_con dcs con+           | dc_name == top_con_name   = False  -- Recursion at the root+           | dc_name `elemNameSet` dcs = True   -- Not at the root+           | otherwise                 = ok_args (dcs `extendNameSet` dc_name) con+           where+             dc_name = getName con -    -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not.-    should_unpack data_cons =+    strict_field :: SrcStrictness -> Bool+    -- True <=> strict field+    strict_field NoSrcStrict = bang_opt_strict_data bang_opts+    strict_field SrcStrict   = True+    strict_field SrcLazy     = False++    -- Determine whether we ought to unpack a field,+    -- based on user annotations if present.+    -- A conservative version of should_unpack that doesn't look at how+    -- many fields the field would unpack to... because that leads to a loop.+    -- "Conservative" = err on the side of saying "yes".+    should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool+    should_unpack_conservative SrcNoUnpack _   = False  -- {-# NOUNPACK #-}+    should_unpack_conservative SrcUnpack   _   = True   -- {-# NOUNPACK #-}+    should_unpack_conservative NoSrcUnpack dcs = not (is_sum dcs)+        -- is_sum: we never unpack sums without a pragma; otherwise be conservative++    -- Determine whether we ought to unpack a field,+    -- based on user annotations if present, and heuristics if not.+    should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool+    should_unpack prag arg_ty data_cons =       case prag of         SrcNoUnpack -> False -- {-# NOUNPACK #-}         SrcUnpack   -> True  -- {-# UNPACK #-}         NoSrcUnpack -- No explicit unpack pragma, so use heuristics-          | (_:_:_) <- data_cons-          -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK.-          | otherwise+          | is_sum data_cons+          -> False -- Don't unpack sum types automatically, but they can+                   -- be unpacked with an explicit source UNPACK.+          | otherwise   -- Wrinkle (W4) of Note [Recursive unboxing]           -> bang_opt_unbox_strict bang_opts              || (bang_opt_unbox_small bang_opts                  && rep_tys `lengthAtMost` 1)  -- See Note [Unpack one-wide fields]-      where (rep_tys, _) = dataConArgUnpack ty+      where+        (rep_tys, _) = dataConArgUnpack arg_ty +    is_sum :: [DataCon] -> Bool+    -- We never unpack sum types automatically+    -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)+    is_sum (_:_:_) = True+    is_sum _       = False  -- Given a type already assumed to have been normalized by topNormaliseType, -- unpackable_type_datacons ty = Just datacons@@ -1398,11 +1423,11 @@ unpackable_type_datacons :: Type -> Maybe [DataCon] unpackable_type_datacons ty   | Just (tc, _) <- splitTyConApp_maybe ty-  , not (isNewTyCon tc)-    -- Even though `ty` has been normalised, it could still-    -- be a /recursive/ newtype, so we must check for that+  , not (isNewTyCon tc)  -- Even though `ty` has been normalised, it could still+                         -- be a /recursive/ newtype, so we must check for that   , Just cons <- tyConDataCons_maybe tc-  , not (null cons)+  , not (null cons)      -- Don't upack nullary sums; no need.+                         -- They already take zero bits   , all (null . dataConExTyCoVars) cons   = Just cons -- See Note [Unpacking GADTs and existentials]   | otherwise@@ -1458,20 +1483,74 @@         data T = MkT {-# UNPACK #-} !T Int Because then we'd get an infinite number of arguments. -Here is a more complicated case:-        data S = MkS {-# UNPACK #-} !T Int-        data T = MkT {-# UNPACK #-} !S Int-Each of S and T must decide independently whether to unpack-and they had better not both say yes. So they must both say no.--Also behave conservatively when there is no UNPACK pragma-        data T = MkS !T Int-with -funbox-strict-fields or -funbox-small-strict-fields-we need to behave as if there was an UNPACK pragma there.--But it's the *argument* type that matters. This is fine:+Note that it's the *argument* type that matters. This is fine:         data S = MkS S !Int because Int is non-recursive.++Wrinkles:++(W1a) We have to be careful that the compiler doesn't go into a loop!+      First, we must not look at the HsImplBang decisions of data constructors+      in the same mutually recursive group.  E.g.+         data S = MkS {-# UNPACK #-} !T Int+         data T = MkT {-# UNPACK #-} !S Int+      Each of S and T must decide /independently/ whether to unpack+      and they had better not both say yes. So they must both say no.+      (We could detect when we leave the group, and /then/ we can rely on+      HsImplBangs; but that requires more plumbing.)++(W1b) Here is another way the compiler might go into a loop (test T23307b):+         data data T = MkT !S Int+         data S = MkS !T+     Suppose we call `shouldUnpackArgTy` on the !S arg of `T`.  In `should_unpack`+     we ask if the number of fields that `MkS` unpacks to is small enough+     (via rep_tys `lengthAtMost` 1).  But how many field /does/ `MkS` unpack+     to?  Well it depends on the unpacking decision we make for `MkS`, which+     in turn depends on `MkT`, which we are busy deciding. Black holes beckon.++     So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;+     see `should_unpack_conservative`), and only /then/ call `should_unpack`.+     Tricky!++(W2) As #23307 shows,  we /do/ want to unpack the second arg of the Yes+     data constructor in this example, despite the recursion in List:+       data Stream a   = Cons a !(Stream a)+       data Unconsed a = Unconsed a !(Stream a)+       data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)+     When looking at+       {-# UNPACK #-} (Unconsed a)+     we can take Unconsed apart, but then get into a loop with Stream.+     That's fine: we can still take Unconsed apart.  It's only if we+     have a loop /at the root/ that we must not unpack.++(W3) Moreover (W2) can apply even if there is a recursive loop:+       data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)+       data Unconsed a = Unconsed a !(List a)+     Here there is mutual recursion between `Unconsed` and `List`; and yet+     we can unpack the field of `Cons` because we will not unpack the second+     field of `Unconsed`: we never unpack a sum type without an explicit+     pragma (see should_unpack).++(W4) Consider+        data T = MkT !Wombat+        data Wombat = MkW {-# UNPACK #-} !S Int+        data S = MkS {-# NOUNPACK #-} !Wombat Int+     Suppose we are deciding whether to unpack the first field of MkT, by+     calling (shouldUnpackArgTy Wombat).  Then we'll try to unpack the !S field+     of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can+     unpack MkT.++     If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would+     decide not to unpack the Wombat field of MkT.++     But what if there was no pragma in `data S`?  Then we /still/ decide not+     to unpack the Wombat field of MkT (at least when auto-unpacking is on),+     because we don't know for sure which decision will be taken for the+     Wombat field of MkS.++     TL;DR when there is no pragma, behave as if there was a UNPACK, at least+     when auto-unpacking is on.  See `should_unpack` in `shouldUnpackArgTy`.+  ************************************************************************ *                                                                      *

@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.6.1+Version: 9.6.2 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.1,-                   ghc-heap   == 9.6.1,-                   ghci == 9.6.1+                   ghc-boot   == 9.6.2,+                   ghc-heap   == 9.6.2,+                   ghci == 9.6.2      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.14

@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.6.1.20230312+version: 9.6.2.20230523 license: BSD3 license-file: LICENSE category: Development

@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "a58c028a181106312e1a783e82a37fc657ce9cfe"+cProjectGitCommitId   = "7e70df17aee2e39bc599b43e59a52bb30064df4d"  cProjectVersion       :: String-cProjectVersion       = "9.6.1"+cProjectVersion       = "9.6.2"  cProjectVersionInt    :: String cProjectVersionInt    = "906"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "1"+cProjectPatchLevel    = "2"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "1"+cProjectPatchLevel1   = "2"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = "0"

@@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_lock 1224 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184+#define OFFSET_Capability_context_switch 1192 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188+#define OFFSET_Capability_interrupt 1196 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320+#define OFFSET_Capability_sparks 1328 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192+#define OFFSET_Capability_total_allocated 1200 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168+#define OFFSET_Capability_weak_ptr_list_hd 1176 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176+#define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0

@@ -2,7 +2,7 @@ -- ./configure.  Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal.  Name: ghc-bin-Version: 9.6.1+Version: 9.6.2 Copyright: XXX -- License: XXX -- License-File: XXX@@ -39,8 +39,8 @@                    filepath   >= 1   && < 1.5,                    containers >= 0.5 && < 0.7,                    transformers >= 0.5 && < 0.7,-                   ghc-boot      == 9.6.1,-                   ghc           == 9.6.1+                   ghc-boot      == 9.6.2,+                   ghc           == 9.6.2      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.14@@ -58,7 +58,7 @@         Build-depends:             deepseq        == 1.4.*,             ghc-prim       >= 0.5.0 && < 0.11,-            ghci           == 9.6.1,+            ghci           == 9.6.2,             haskeline      == 0.8.*,             exceptions     == 0.10.*,             time           >= 1.8 && < 1.13

@@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal.  name:           ghc-boot-th-version:        9.6.1+version:        9.6.2 license:        BSD3 license-file:   LICENSE category:       GHC

@@ -98,6 +98,7 @@    | OSAIX    | OSHurd    | OSWasi+   | OSGhcjs    deriving (Read, Show, Eq, Ord)  @@ -157,3 +158,4 @@   OSAIX       -> "aix"   OSHurd      -> "hurd"   OSWasi      -> "wasi"+  OSGhcjs     -> "ghcjs"

@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.6.1+version:        9.6.2 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -77,7 +77,7 @@                    directory  >= 1.2 && < 1.4,                    filepath   >= 1.3 && < 1.5,                    deepseq    >= 1.4 && < 1.5,-                   ghc-boot-th == 9.6.1+                   ghc-boot-th == 9.6.2     if !os(windows)         build-depends:                    unix       >= 2.7 && < 2.9

@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.6.1+version:        9.6.2 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org

@@ -465,7 +465,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \   (major1) == 9 && (major2) <  6 || \-  (major1) == 9 && (major2) == 6 && (minor) <= 1)+  (major1) == 9 && (major2) == 6 && (minor) <= 2) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo

@@ -2,7 +2,7 @@ -- ../../configure.  Make sure you are editing ghci.cabal.in, not ghci.cabal.  name:           ghci-version:        9.6.1+version:        9.6.2 license:        BSD3 license-file:   LICENSE category:       GHC@@ -77,8 +77,8 @@         containers       >= 0.5 && < 0.7,         deepseq          == 1.4.*,         filepath         == 1.4.*,-        ghc-boot         == 9.6.1,-        ghc-heap         == 9.6.1,+        ghc-boot         == 9.6.2,+        ghc-heap         == 9.6.2,         template-haskell == 2.20.*,         transformers     >= 0.5 && < 0.7 

@@ -56,7 +56,7 @@      build-depends:         base        >= 4.11 && < 4.19,-        ghc-boot-th == 9.6.1,+        ghc-boot-th == 9.6.2,         ghc-prim,         pretty      == 1.1.*