diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -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 diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs --- a/GHC/Core/Opt/SpecConstr.hs +++ b/GHC/Core/Opt/SpecConstr.hs @@ -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 diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -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 diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs --- a/GHC/Core/Ppr.hs +++ b/GHC/Core/Ppr.hs @@ -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 diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs --- a/GHC/Core/Rules.hs +++ b/GHC/Core/Rules.hs @@ -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) diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs --- a/GHC/Core/Subst.hs +++ b/GHC/Core/Subst.hs @@ -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 diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -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 diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -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 diff --git a/GHC/Plugins.hs b/GHC/Plugins.hs --- a/GHC/Plugins.hs +++ b/GHC/Plugins.hs @@ -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 diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -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