ghc 9.4.6 → 9.4.7

raw patch · 10 files changed

+220/−143 lines, 10 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/Lexer.hs +2/−2
• GHC/Core/Opt/SpecConstr.hs +2/−1
• GHC/Core/Opt/Specialise.hs +181/−110
• GHC/Core/Ppr.hs +8/−1
• GHC/Core/Rules.hs +1/−1
• GHC/Core/Subst.hs +17/−19
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +2/−2
• GHC/Plugins.hs +1/−1
• ghc.cabal +4/−4

@@ -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.4.6-src/ghc-9.4.6/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/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.4.6-src/ghc-9.4.6/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 133 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken   = CmmT_SpecChar  Char   | CmmT_DotDot

@@ -929,7 +929,8 @@  extendScInScope :: ScEnv -> [Var] -> ScEnv         -- Bring the quantified variables into scope-extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }+extendScInScope env qvars+  = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }          -- Extend the substitution extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv

@@ -689,18 +689,18 @@                                  -- See Note [specImport call stack]              -> RuleBase         -- Rules from this module and the home package                                  -- (but not external packages, which can change)-             -> Bag DictBind     -- Dict bindings, used /only/ for filterCalls+             -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls                                  -- See Note [Avoiding loops in specImports]              -> CallDetails      -- Calls for imported things              -> CoreM ( [CoreRule]   -- New rules                       , [CoreBind] ) -- Specialised bindings spec_imports top_env callers rule_base dict_binds calls   = do { let import_calls = dVarEnvElts calls-       -- ; debugTraceMsg (text "specImports {" <+>-       --                  vcat [ text "calls:" <+> ppr import_calls-       --                       , text "dict_binds:" <+> ppr dict_binds ])+--       ; debugTraceMsg (text "specImports {" <+>+--                         vcat [ text "calls:" <+> ppr import_calls+--                              , text "dict_binds:" <+> ppr dict_binds ])        ; (rules, spec_binds) <- go rule_base import_calls-       -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)+--       ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)         ; return (rules, spec_binds) }   where@@ -709,7 +709,7 @@     go rb (cis : other_calls)       = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)            ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis-           -- ; debugTraceMsg (text "specImport }" <+> ppr cis)+           ; -- debugTraceMsg (text "specImport }" <+> ppr cis)             ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }@@ -718,7 +718,7 @@             -> [Id]                  -- Stack of imported functions being specialised                                      -- See Note [specImport call stack]             -> RuleBase              -- Rules from this module-            -> Bag DictBind          -- Dict bindings, used /only/ for filterCalls+            -> FloatedDictBinds      -- Dict bindings, used /only/ for filterCalls                                      -- See Note [Avoiding loops in specImports]             -> CallInfoSet           -- Imported function and calls for it             -> CoreM ( [CoreRule]    -- New rules@@ -742,20 +742,22 @@        ; vis_orphs <- getVisibleOrphanMods        ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn +       ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])        ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })-            <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>-                (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs)+            <- runSpecM $ specCalls True top_env dict_binds+                             rules_for_fn good_calls fn rhs+        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]              -- After the rules kick in we may get recursion, but              -- we rely on a global GlomBinds to sort that out later              -- See Note [Glom the bindings if imported functions are specialised]                -- Now specialise any cascaded calls-       -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))+       ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))        ; (rules2, spec_binds2) <- spec_imports top_env                                                (fn:callers)                                                (extendRuleBaseList rb rules1)-                                               (dict_binds `unionBags` dict_binds1)+                                               (dict_binds `thenFDBs` dict_binds1)                                                new_calls         ; let final_binds = wrapDictBinds dict_binds1 $@@ -1112,17 +1114,20 @@        ; return (Tick (specTickish env tickish) body', uds) }  ---------------- Applications might generate a call instance ---------------------specExpr env expr@(App {})-  = go expr []+specExpr top_env expr@(App {})+  = go top_env expr []   where-    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg-                               (fun', uds_app) <- go fun (arg':args)-                               return (App fun' arg', uds_arg `plusUDs` uds_app)+    go env (App fun arg) args = do (arg', uds_arg) <- specExpr env arg+                                   let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_arg+                                   -- Some dicts may have floated out of arg;+                                   -- they should be in scope (#21689)+                                   (fun', uds_app) <- go env_args fun (arg':args)+                                   return (App fun' arg', uds_arg `thenUDs` uds_app) -    go (Var f)       args = case specVar env f of-                                Var f' -> return (Var f', mkCallUDs env f' args)-                                e'     -> return (e', emptyUDs) -- I don't expect this!-    go other         _    = specExpr env other+    go env (Var f)       args = case specVar env f of+                                    Var f' -> return (Var f', mkCallUDs env f' args)+                                    e'     -> return (e', emptyUDs) -- I don't expect this!+    go env other         _    = specExpr env other  ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {})@@ -1138,7 +1143,7 @@        ; (scrut'', case_bndr', alts', alts_uds)              <- specCase env scrut' case_bndr alts        ; return (Case scrut'' case_bndr' (substTy env ty) alts'-                , scrut_uds `plusUDs` alts_uds) }+                , scrut_uds `thenUDs` alts_uds) }  ---------------- Finally, let is the interesting case -------------------- specExpr env (Let bind body)@@ -1149,7 +1154,7 @@        ; (body', body_uds) <- specExpr body_env body          -- Deal with the bindings-      ; (binds', uds) <- specBind rhs_env bind' body_uds+       ; (binds', uds) <- specBind rhs_env bind' body_uds          -- All done       ; return (foldr Let body' binds', uds) }@@ -1211,7 +1216,7 @@                              | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]              flt_binds     = scrut_bind : sc_binds              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds-             all_uds = flt_binds `addDictBinds` free_uds+             all_uds = flt_binds `consDictBinds` free_uds              alt'    = Alt con args' (wrapDictBindsE dumped_dbs rhs')        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }   where@@ -1287,6 +1292,13 @@ ************************************************************************ -} +bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv+bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })+  = -- pprTrace "brought into scope" (ppr dx_bndrs) $+    env {se_subst=subst'}+  where+   subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs+ specBind :: SpecEnv                     -- Use this for RHSs          -> CoreBind                    -- Binders are already cloned by cloneBindSM,                                         -- but RHSs are un-processed@@ -1310,7 +1322,7 @@                         -- fn' mentions the spec_defns in its rules,                         -- so put the latter first -             combined_uds = body_uds1 `plusUDs` rhs_uds+             combined_uds = body_uds1 `thenUDs` rhs_uds               (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds @@ -1341,7 +1353,7 @@        -- Note [Specialising a recursive group]   = do { let (bndrs,rhss) = unzip pairs        ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss-       ; let scope_uds = body_uds `plusUDs` rhs_uds+       ; let scope_uds = body_uds `thenUDs` rhs_uds                        -- Includes binds and calls arising from rhss         ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs@@ -1381,8 +1393,8 @@ specDefns _env uds []   = return ([], [], uds) specDefns env uds ((bndr,rhs):pairs)-  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs-       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds  pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn  env uds1 bndr rhs        ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }  ---------------------------@@ -1396,12 +1408,15 @@ specDefn env body_uds fn rhs   = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds              rules_for_me = idCoreRules fn-       ; (rules, spec_defns, spec_uds) <- specCalls False env rules_for_me-                                                    calls_for_me fn rhs+             dict_binds   = ud_binds body_uds++       ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds+                                               rules_for_me calls_for_me fn rhs+        ; return ( fn `addIdSpecialisations` rules                 , spec_defns-                , body_uds_without_me `plusUDs` spec_uds) }-                -- It's important that the `plusUDs` is this way+                , body_uds_without_me `thenUDs` spec_uds) }+                -- It's important that the `thenUDs` is this way                 -- round, because body_uds_without_me may bind                 -- dictionaries that are used in calls_for_me passed                 -- to specDefn.  So the dictionary bindings in@@ -1412,6 +1427,7 @@ specCalls :: Bool              -- True  =>  specialising imported fn                                -- False =>  specialising local fn           -> SpecEnv+          -> FloatedDictBinds  -- Just so that we can extend the in-scope set           -> [CoreRule]        -- Existing RULES for the fn           -> [CallInfo]           -> OutId -> InExpr@@ -1425,7 +1441,7 @@                 , [(Id,CoreExpr)]  -- Specialised definition                 , UsageDetails )   -- Usage details from specialised RHSs -specCalls spec_imp env existing_rules calls_for_me fn rhs+specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs         -- The first case is the interesting one   |  notNull calls_for_me               -- And there are some calls to specialise   && not (isNeverActive (idInlineActivation fn))@@ -1441,14 +1457,14 @@ --      See Note [Inline specialisations] for why we do not --      switch off specialisation for inline functions -  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $+  = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)           "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $           -- Note [Specialisation shape]-    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $+    -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)   where     _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]@@ -1461,7 +1477,6 @@     is_local  = isLocalId fn     is_dfun   = isDFunId fn     dflags    = se_dflags env-    ropts     = initRuleOpts dflags     this_mod  = se_module env         -- Figure out whether the function has an INLINE pragma         -- See Note [Inline specialisations]@@ -1469,13 +1484,12 @@     (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs                             -- See Note [Account for casts in binding] -    in_scope = Core.substInScope (se_subst env)+    -- Bring into scope the binders from the floated dicts+    env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds -    already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool-    already_covered ropts new_rules args      -- Note [Specialisations already covered]-       = isJust (lookupRule ropts (in_scope, realIdUnfolding)-                            (const True) fn args-                            (new_rules ++ existing_rules))+    already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool+    already_covered env new_rules args      -- Note [Specialisations already covered]+       = isJust (specLookupRule env fn args (new_rules ++ existing_rules))          -- NB: we look both in the new_rules (generated by this invocation          --     of specCalls), and in existing_rules (passed in to specCalls) @@ -1491,21 +1505,25 @@                                -- See Note [Specialising DFuns]            ; ( useful, rhs_env2, leftover_bndrs              , rule_bndrs, rule_lhs_args-             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args+             , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs+                                                               rhs_bndrs all_call_args ---           ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci---                                        , text "useful:    " <+> ppr useful---                                        , text "rule_bndrs:" <+> ppr rule_bndrs---                                        , text "lhs_args:  " <+> ppr rule_lhs_args---                                        , text "spec_bndrs:" <+> ppr spec_bndrs1---                                        , text "spec_args: " <+> ppr spec_args---                                        , text "dx_binds:  " <+> ppr dx_binds---                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)+--           ; pprTrace "spec_call" (vcat [ text "fun:       "  <+> ppr fn+--                                        , text "call info: "  <+> ppr _ci+--                                        , text "useful:    "  <+> ppr useful+--                                        , text "rule_bndrs:"  <+> ppr rule_bndrs+--                                        , text "lhs_args:  "  <+> ppr rule_lhs_args+--                                        , text "spec_bndrs1:" <+> ppr spec_bndrs1+--                                        , text "leftover_bndrs:" <+> pprIds leftover_bndrs+--                                        , text "spec_args: "  <+> ppr spec_args+--                                        , text "dx_binds:  "  <+> ppr dx_binds+--                                        , text "rhs_body"     <+> ppr rhs_body+--                                        , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2) --                                        , ppr dx_binds ]) $ --             return ()             ; if not useful  -- No useful specialisation-                || already_covered ropts rules_acc rule_lhs_args+                || already_covered rhs_env2 rules_acc rule_lhs_args              then return spec_acc              else         do { -- Run the specialiser on the specialised RHS@@ -1616,9 +1634,20 @@            ; -- pprTrace "spec_call: rule" _rule_trace_doc              return ( spec_rule                  : rules_acc                     , (spec_f_w_arity, spec_rhs) : pairs_acc-                    , spec_uds           `plusUDs` uds_acc+                    , spec_uds           `thenUDs` uds_acc                     ) } } +-- Convenience function for invoking lookupRule from Specialise+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]+specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+specLookupRule env fn args rules+  = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules+  where+    dflags   = se_dflags env+    in_scope = Core.substInScope (se_subst env)+    ropts    = initRuleOpts dflags++ {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DFuns have a special sort of unfolding (DFunUnfolding), and it is@@ -2357,12 +2386,12 @@ -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. specHeader env (bndr : bndrs) (SpecDict d : args)-  = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]-       ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d-       ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args+  = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]+       ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d+       ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader env2 bndrs args        ; pure ( True      -- Ha!  A useful specialisation!-              , env''+              , env3               , leftover_bndrs               -- See Note [Evidence foralls]               , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs@@ -2416,9 +2445,9 @@ bindAuxiliaryDict   :: SpecEnv   -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression-  -> ( SpecEnv        -- Substitute for orig_dict_id+  -> ( SpecEnv        -- Substitutes for orig_dict_id      , Maybe DictBind -- Auxiliary dict binding, if any-     , OutExpr)        -- Witnessing expression (always trivial)+     , OutExpr)       -- Witnessing expression (always trivial) bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })                   orig_dict_id fresh_dict_id dict_expr @@ -2426,7 +2455,6 @@   -- don’t bother creating a new dict binding; just substitute   | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr   = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr-                                `Core.extendInScope` dict_id                           -- See Note [Keep the old dictionaries interesting]                    , se_interesting = interesting `extendVarSet` dict_id }     in (env', Nothing, dict_expr)@@ -2434,7 +2462,7 @@   | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding   = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)         env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)-                                `Core.extendInScope` fresh_dict_id+                                `Core.extendSubstInScope` fresh_dict_id                       -- See Note [Make the new dictionaries interesting]                    , se_interesting = interesting `extendVarSet` fresh_dict_id }     in (env', Just dict_bind, Var fresh_dict_id)@@ -2499,24 +2527,34 @@ ********************************************************************* -}  data UsageDetails-  = MkUD {-      ud_binds :: !(Bag DictBind),-               -- See Note [Floated dictionary bindings]+  = MkUD { ud_binds :: !FloatedDictBinds+         , ud_calls :: !CallDetails }+    -- INVARIANT: suppose bs = fdb_bndrs ud_binds+    -- Then 'calls' may *mention* 'bs',+    -- but there should be no calls *for* bs++data FloatedDictBinds  -- See Note [Floated dictionary bindings]+  = FDB { fdb_binds :: !(Bag DictBind)                -- The order is important;-               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1+               -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1                -- (Remember, Bags preserve order in GHC.) -      ud_calls :: !CallDetails--      -- INVARIANT: suppose bs = bindersOf ud_binds-      -- Then 'calls' may *mention* 'bs',-      -- but there should be no calls *for* bs-    }+        , fdb_bndrs :: !IdSet+    }          -- ^ The binders of 'fdb_binds'.+               -- Caches a superset of the expression+               --   `mkVarSet (bindersOfDictBinds fdb_binds))`+               -- for later addition to an InScopeSet  -- | A 'DictBind' is a binding along with a cached set containing its free -- variables (both type variables and dictionaries) data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } +bindersOfDictBind :: DictBind -> [Id]+bindersOfDictBind = bindersOf . db_bind++bindersOfDictBinds :: Foldable f => f DictBind -> [Id]+bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []+ {- Note [Floated dictionary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We float out dictionary bindings for the reasons described under@@ -2542,12 +2580,16 @@  So the DictBinds in (ud_binds :: Bag DictBind) may contain non-dictionary bindings too.++It's important to add the dictionary binders that are currently in-float to the+InScopeSet of the SpecEnv before calling 'specBind'. That's what we do when we+call 'bringFloatedDictsIntoScope'. -}  instance Outputable DictBind where   ppr (DB { db_bind = bind, db_fvs = fvs })-    = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind-                                , text "fvs: " <+> ppr fvs ])+    = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs+                                , text "bind:" <+> ppr bind ])  instance Outputable UsageDetails where   ppr (MkUD { ud_binds = dbs, ud_calls = calls })@@ -2555,9 +2597,16 @@                 [text "binds" <+> equals <+> ppr dbs,                  text "calls" <+> equals <+> ppr calls])) +instance Outputable FloatedDictBinds where+  ppr (FDB { fdb_binds = binds }) = ppr binds+ emptyUDs :: UsageDetails-emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }+emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv } ++emptyFDBs :: FloatedDictBinds+emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet }+ ------------------------------------------------------------ type CallDetails  = DIdEnv CallInfoSet   -- The order of specialized binds and rules depends on how we linearize@@ -2624,7 +2673,7 @@ ------------------------------------------------------------ singleCall :: Id -> [SpecArg] -> UsageDetails singleCall id args-  = MkUD {ud_binds = emptyBag,+  = MkUD {ud_binds = emptyFDBs,           ud_calls = unitDVarEnv id $ CIS id $                      unitBag (CI { ci_key  = args -- used to be tys                                  , ci_fvs  = call_fvs }) }@@ -2767,12 +2816,20 @@ interestingDict env (Cast e _)            = interestingDict env e interestingDict _ _                       = True -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails-plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})+thenUDs :: UsageDetails -> UsageDetails -> UsageDetails+thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})         (MkUD {ud_binds = db2, ud_calls = calls2})-  = MkUD { ud_binds = db1    `unionBags`   db2-         , ud_calls = calls1 `unionCalls`  calls2 }+  = MkUD { ud_binds       = db1    `thenFDBs`   db2+         , ud_calls       = calls1 `unionCalls`  calls2 } +thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds+-- Combine FloatedDictBinds+-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa+thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })+         (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })+  = FDB { fdb_binds = dbs1 `unionBags` dbs2+        , fdb_bndrs = bs1  `unionVarSet` bs2 }+ ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id] _dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs@@ -2784,9 +2841,8 @@ -- | Identify the free variables of a 'CoreBind' bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)-bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs+bind_fvs (Rec prs)         = rhs_fvs `delVarSetList` (map fst prs)                            where-                             bndrs = map fst prs                              rhs_fvs = unionVarSets (map pair_fvs prs)  pair_fvs :: (Id, CoreExpr) -> VarSet@@ -2811,7 +2867,8 @@ -- pairs, into a single recursive binding. recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind recWithDumpedDicts pairs dbs-  = DB { db_bind = Rec bindings, db_fvs = fvs }+  = DB { db_bind = Rec bindings+       , db_fvs = fvs `delVarSetList` map fst bindings }   where     (bindings, fvs) = foldr add ([], emptyVarSet)                                 (dbs `snocBag` mkDB (Rec pairs))@@ -2822,22 +2879,29 @@       where         fvs' = fvs_acc `unionVarSet` fvs +snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db+  = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db+                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }+ snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds-snocDictBinds uds dbs-  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }+snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs+  = uds { ud_binds = FDB { fdb_binds = binds `unionBags`        listToBag dbs+                         , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }  consDictBind :: DictBind -> UsageDetails -> UsageDetails-consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }--addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails-addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }+consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}+  = uds { ud_binds = FDB { fdb_binds = db `consBag` binds+                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } -snocDictBind :: UsageDetails -> DictBind -> UsageDetails-snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }+consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}+  = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds+                        , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } -wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]-wrapDictBinds dbs binds+wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]+wrapDictBinds (FDB { fdb_binds = dbs }) binds   = foldr add binds dbs   where     add (DB { db_bind = bind }) binds = bind : binds@@ -2856,7 +2920,7 @@   | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $                  (free_uds, dump_dbs)   where-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }     bndr_set = mkVarSet bndrs     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set     free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor@@ -2880,17 +2944,15 @@     float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls  callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])-callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }   = -- pprTrace ("callsForMe")     --          (vcat [ppr fn,     --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),     --                 text "Orig calls ="   <+> ppr orig_calls,-    --                 text "Dep set ="      <+> ppr dep_set,     --                 text "Calls for me =" <+> ppr calls_for_me]) $     (uds_without_me, calls_for_me)   where-    uds_without_me = MkUD { ud_binds = orig_dbs-                          , ud_calls = delDVarEnv orig_calls fn }+    uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn }     calls_for_me = case lookupDVarEnv orig_calls fn of                         Nothing -> []                         Just cis -> filterCalls cis orig_dbs@@ -2898,10 +2960,10 @@          -- refer to fn.  See Note [Avoiding loops (DFuns)]  -----------------------filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- Remove dominated calls+filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]+-- Remove dominated calls (Note [Specialising polymorphic dictionaries]) -- and loopy DFuns (Note [Avoiding loops (DFuns)])-filterCalls (CIS fn call_bag) dbs+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })   | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns   = filter ok_call unfiltered_calls   | otherwise         -- Do not apply it to non-DFuns@@ -2922,18 +2984,23 @@     ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set  -----------------------splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet) -- splitDictBinds dbs bndrs returns --   (free_dbs, dump_dbs, dump_set) -- where --   * dump_dbs depends, transitively on bndrs --   * free_dbs does not depend on bndrs --   * dump_set = bndrs `union` bndrs(dump_dbs)-splitDictBinds dbs bndr_set-   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set+   = (FDB { fdb_binds = free_dbs+          , fdb_bndrs = bs `minusVarSet` dump_set }+     , dump_dbs, dump_set)+   where+    (free_dbs, dump_dbs, dump_set)+      = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs                 -- Important that it's foldl' not foldr;                 -- we're accumulating the set of dumped ids in dump_set-   where+     split_db (free_dbs, dump_dbs, dump_idset) db         | DB { db_bind = bind, db_fvs = fvs } <- db         , dump_idset `intersectsVarSet` fvs     -- Dump it@@ -2975,7 +3042,7 @@ mapAndCombineSM _ []     = return ([], emptyUDs) mapAndCombineSM f (x:xs) = do (y, uds1) <- f x                               (ys, uds2) <- mapAndCombineSM f xs-                              return (y:ys, uds1 `plusUDs` uds2)+                              return (y:ys, uds1 `thenUDs` uds2)  extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv extendTvSubstList env tv_binds@@ -3004,6 +3071,7 @@              interesting' | interestingDict env rhs                           = interesting `extendVarSet` bndr'                           | otherwise = interesting+--       ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return ()        ; return (env, env { se_subst = subst', se_interesting = interesting' }                 , NonRec bndr' rhs) } @@ -3015,13 +3083,16 @@                                            [ v | (v,r) <- pairs, interestingDict env r ] }        ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } -newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr+newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) -- Make up completely fresh binders for the dictionaries -- Their bindings are going to float outwards-newDictBndr env b = do { uniq <- getUniqueM-                        ; let n   = idName b-                              ty' = substTy env (idType b)-                        ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) }+newDictBndr env@(SE { se_subst = subst }) b+  = do { uniq <- getUniqueM+       ; let n    = idName b+             ty'  = Core.substTy subst (idType b)+             b'   = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)+             env' = env { se_subst = subst `Core.extendSubstInScope` b' }+       ; pure (env', b') }  newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id     -- Give the new Id a similar occurrence name to the old one

@@ -22,7 +22,7 @@         pprCoreExpr, pprParendExpr,         pprCoreBinding, pprCoreBindings, pprCoreAlt,         pprCoreBindingWithSize, pprCoreBindingsWithSize,-        pprCoreBinder, pprCoreBinders,+        pprCoreBinder, pprCoreBinders, pprId, pprIds,         pprRule, pprRules, pprOptCo,         pprOcc, pprOccWithTick     ) where@@ -465,6 +465,13 @@ -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar   = text "@" <> pprTyVar tyvar++-- pprId x prints x :: ty+pprId :: Id -> SDoc+pprId x = ppr x <+> dcolon <+> ppr (idType x)++pprIds :: [Id] -> SDoc+pprIds xs = sep (map pprId xs)  -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness

@@ -405,7 +405,7 @@ -- See Note [Extra args in the target] -- See comments on matchRule lookupRule opts rule_env@(in_scope,_) is_active fn args rules-  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $+  = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $     case go [] rules of         []     -> Nothing         (m:ms) -> Just (findBest in_scope (fn,args') m ms)

@@ -24,7 +24,7 @@         emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,         extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,-        extendInScope, extendInScopeList, extendInScopeIds,+        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,         delBndr, delBndrs, @@ -50,7 +50,7 @@ import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )  import GHC.Types.Var.Set-import GHC.Types.Var.Env+import GHC.Types.Var.Env as InScopeSet import GHC.Types.Id import GHC.Types.Name     ( Name ) import GHC.Types.Var@@ -284,25 +284,23 @@ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope --- | Add the 'Var' to the in-scope set: as a side effect,--- and remove any existing substitutions for it-extendInScope :: Subst -> Var -> Subst-extendInScope (Subst in_scope ids tvs cvs) v-  = Subst (in_scope `extendInScopeSet` v)-          (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)+-- | Add the 'Var' to the in-scope set+extendSubstInScope :: Subst -> Var -> Subst+extendSubstInScope (Subst in_scope ids tvs cvs) v+  = Subst (in_scope `InScopeSet.extendInScopeSet` v)+          ids tvs cvs  -- | Add the 'Var's to the in-scope set: see also 'extendInScope'-extendInScopeList :: Subst -> [Var] -> Subst-extendInScopeList (Subst in_scope ids tvs cvs) vs+extendSubstInScopeList :: Subst -> [Var] -> Subst+extendSubstInScopeList (Subst in_scope ids tvs cvs) vs   = Subst (in_scope `extendInScopeSetList` vs)-          (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)+          ids tvs cvs --- | Optimized version of 'extendInScopeList' that can be used if you are certain--- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's-extendInScopeIds :: Subst -> [Id] -> Subst-extendInScopeIds (Subst in_scope ids tvs cvs) vs-  = Subst (in_scope `extendInScopeSetList` vs)-          (ids `delVarEnvList` vs) tvs cvs+-- | Add the 'Var's to the in-scope set: see also 'extendInScope'+extendSubstInScopeSet :: Subst -> VarSet -> Subst+extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetSet` vs)+          ids tvs cvs  setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs@@ -462,7 +460,7 @@  substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $-    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)+    (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id)   where     id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary     id2 | no_type_change = id1@@ -532,7 +530,7 @@             -> (Subst, Id)              -- Transformed pair  clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)-  = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)+  = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)   where     id1     = setVarUnique old_id uniq     id2     = substIdType subst id1

@@ -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.4.6-src/ghc-9.4.6/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/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.4.6-src/ghc-9.4.6/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/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.4.6-src/ghc-9.4.6/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -609,7 +609,7 @@   , (0,alex_action_84)   ] -{-# LINE 700 "_build/source-dist/ghc-9.4.6-src/ghc-9.4.6/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 700 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type 

@@ -89,7 +89,7 @@ import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )+import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet )        -- These names are also exported by Type  import GHC.Core.Rules

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