Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 5bdcdf82 by Simon Peyton Jones at 2026-04-07T23:25:52+01:00 Wibbles [skip ci] - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Rules.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -40,7 +40,8 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) -import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Rules ( RuleMatch(..), applyBindWrapper, isEmptyBindWrapper + , lookupRule, getRules ) import GHC.Core.Multiplicity import GHC.Hs.Extension @@ -2298,7 +2299,7 @@ simplOutExpr env expr cont _ -> rebuild_go env expr cont where (fun, args) = collectArgs expr - cont' = pushArgs env Simplified (expType fun) args cont + cont' = pushArgs env Simplified (exprType fun) args cont occ_fun = occurAnalyseExpr fun -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] --------------------------------------------------------- @@ -2364,10 +2365,14 @@ simplOutId env fun cont then tryRules env rules_for_me fun out_args else return Nothing ; case mb_match of { - Just (rule_arity, rhs, rhs_args ) -> simplExprF env rhs $ - pushArgs env NoDup rhs_args $ - dropContArgs rule_arity cont ; - Nothing -> + Just (RM { rm_rule = rule, rm_rhs = rhs + , rm_args = rhs_args, rm_binds = wrap }) + -> simplExprF env rhs' $ + dropContArgs (ruleArity rule) cont + where + rhs' = applyBindWrapper wrap $ + mkApps rhs rhs_args + ; Nothing -> -- Try inlining do { logger <- getLogger @@ -2451,18 +2456,15 @@ rebuildCall env fun_info ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } ---------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_arg_specs, ai_rules = rules }) cont | null rules - = rebuild env (argInfoExpr fun rev_args) cont + = rebuild env (argInfoExpr fun rev_arg_specs) cont | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] - = do { let args = reverse rev_args - ; mb_match <- tryRules env rules fun (map argSpecArg args) + = do { let arg_specs = reverse rev_arg_specs + ; mb_match <- tryRules env rules fun (map argSpecArg arg_specs) ; case mb_match of - Just (rule_arity, rhs, rhs_args) - -> simplExprF env rhs $ - pushArgs env Simplified rhs_args $ - pushArgSpecs env (drop rule_arity args) cont - Nothing -> rebuild env (argInfoExpr fun rev_args) cont } + Just rule_match -> fireRuleAFTER env rule_match arg_specs cont + Nothing -> rebuild env (argInfoExpr fun rev_arg_specs) cont } ----------------------------------- tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) @@ -2644,20 +2646,36 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ -} +fireRuleAFTER :: SimplEnv -> RuleMatch + -> [ArgSpec] -> SimplCont + -> SimplM (SimplFloats, CoreExpr) +fireRuleAFTER env rule_match arg_specs cont + | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args + , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match + = do { let env' = env `addNewInScopeIds` bndrs + ; (floats, e') <- simplExprF env' rhs $ + pushArgs env' Simplified (exprType rhs) rhs_args $ + pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont + ; return $ + if isEmptyBindWrapper wrap + then (floats, e') + else (emptyFloats env', applyBindWrapper wrap $ + wrapFloats floats e') } + + tryRules :: SimplEnv -> [CoreRule] -> OutId -> [OutExpr] - -> SimplM (Maybe (FullArgCount, CoreExpr, [CoreExpr])) + -> SimplM (Maybe RuleMatch) tryRules env rules fn args - | Just (rule, rule_rhs, rule_args) <- lookupRule ropts in_scope_env - act_fun fn args rules - -- Fire a rule for the function - = do { logger <- getLogger - ; checkedTick (RuleFired (ruleName rule)) --- ; let occ_anald_rhs = occurAnalyseExpr rule_rhs --- -- See Note [Occurrence-analyse after rule firing] - ; dump logger rule rule_rhs - ; return (Just (ruleArity rule, rhs_rhs, rule_args)) } + | Just rule_match <- lookupRule ropts in_scope_env + act_fun fn args rules + -- Fire a rule for the function + = do { let the_rule = rm_rule rule_match + ; logger <- getLogger + ; checkedTick (RuleFired (ruleName the_rule)) + ; dump logger the_rule (rm_rhs rule_match) + ; return (Just rule_match) } | otherwise -- No rule fires = do { logger <- getLogger @@ -2723,12 +2741,8 @@ trySeqRules in_env scrut rhs cont ; let seq_rules = getRules rule_base seqId ; mb_match <- tryRules in_env seq_rules seqId out_args ; case mb_match of - Nothing -> return Nothing - Just (rule_arity, rhs, rhs_args) -> return (Just (rhs, cont')) - where - cont' = pushArgs in_env Simplified rhs_args $ - pushArgSpecs in_env (drop rule_arity out_arg_specs) rule_cont - } + Nothing -> return Nothing + Just rule_match -> Just <$> fireRuleAFTER in_env rule_match out_arg_specs cont } where no_cast_scrut = drop_casts scrut ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -10,6 +10,7 @@ module GHC.Core.Rules ( -- ** Looking up rules RuleMatch(..), lookupRule, matchExprs, ruleLhsIsMoreSpecific, + BindWrapper, isEmptyBindWrapper, applyBindWrapper, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -88,6 +89,7 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag +import GHC.Data.OrdList import GHC.Data.List.SetOps( hasNoDups ) import GHC.Utils.FV( filterFV, fvVarSet ) @@ -591,7 +593,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules go ms [] = ms go ms (r:rs) | Just rm <- matchRule opts rule_env is_active fn args' rough_args r - = go (rm { rm_binds = mkTicks ticks . rm_binds rm } : ms) rs + = go (rm { rm_binds = mkTicks ticks `consOL` rm_binds rm } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -746,7 +748,7 @@ matchRule opts rule_env _is_active fn args _rough_args ; return (RM { rm_rule = rule , rm_rhs = rhs , rm_args = [] - , rm_binds = id + , rm_binds = emptyBindWrapper , rm_bndrs = [] }) } matchRule _opts rule_env is_active _fn target_es rough_args @@ -968,13 +970,23 @@ data RuleSubst = RS { -- Substitution; applied only to the template, not the tar , rs_bndrs :: [Var] -- Variables bound by floated lets } -type BindWrapper = CoreExpr -> CoreExpr +type BindWrapper = OrdList (CoreExpr -> CoreExpr) -- See Notes [Matching lets] and [Matching cases] -- we represent the floated bindings as a core-to-core function + -- WE use an OrdList so that we can tell the common case of an empty wrapper + +emptyBindWrapper :: BindWrapper +emptyBindWrapper = nilOL + +isEmptyBindWrapper :: BindWrapper -> Bool +isEmptyBindWrapper = isNilOL + +applyBindWrapper :: BindWrapper -> CoreExpr -> CoreExpr +applyBindWrapper bw e = foldrOL ($) e bw emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv - , rs_binds = \e -> e, rs_bndrs = [] } + , rs_binds = nilOL, rs_bndrs = [] } {- Note [Casts in the target] @@ -1110,7 +1122,7 @@ match renv subst e1 (Tick t e2) mco | otherwise = Nothing where - subst' = subst { rs_binds = rs_binds subst . mkTick t } + subst' = subst { rs_binds = rs_binds subst `snocOL` mkTick t } match renv subst e@(Tick t e1) e2 mco | tickishFloatable t -- Ignore floatable ticks in rule template. @@ -1344,7 +1356,7 @@ match renv subst e1 (Let bind e2) mco -- We are floating the let-binding out, as if it had enclosed -- the entire target from Day 1. So we must add its binders to -- the in-scope set (#20200) - (subst { rs_binds = rs_binds subst . Let bind' + (subst { rs_binds = rs_binds subst `snocOL` Let bind' , rs_bndrs = new_bndrs ++ rs_bndrs subst }) e1 e2 mco | otherwise @@ -1370,7 +1382,7 @@ match renv subst (Lam x1 e1) e2 mco , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 -- See Note [Lambdas in the template] = let renv' = rnMatchBndr2 renv x1 x2 - subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + subst' = subst { rs_binds = rs_binds subst `snocOL` flip (foldr mkTick) ts } in match renv' subst' e1 e2' MRefl match renv subst e1 e2@(Lam {}) mco @@ -1435,11 +1447,11 @@ match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ ( eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) -- See Note [Eta reduction in the target] eta_reduce renv e@(Lam {}) - = go renv id [] e + = go renv emptyBindWrapper [] e where go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) - go renv bw vs (Let b e) = go renv (bw . Let b) vs e + go renv bw vs (Let b e) = go renv (bw `snocOL` Let b) vs e go renv bw vs (Lam v e) = go renv' bw (v':vs) e where @@ -1454,7 +1466,7 @@ eta_reduce renv e@(Lam {}) , v == rnOccR (rv_lcl renv) tv = go renv bw vs f - go renv bw [] e = Just (renv, bw e) + go renv bw [] e = Just (renv, applyBindWrapper bw e) go _ _ (_:_) _ = Nothing eta_reduce _ _ = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bdcdf82179fbeb1748127ba46a6eb25... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bdcdf82179fbeb1748127ba46a6eb25... You're receiving this email because of your account on gitlab.haskell.org.