Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 39d59acd by Simon Peyton Jones at 2026-03-17T10:26:25+00:00 Avoid more re-simplification - - - - - 4 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -40,7 +40,7 @@ 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 ( lookupRule, getRules, RuleMatch(..) ) import GHC.Core.Multiplicity import GHC.Hs.Extension @@ -413,9 +413,9 @@ simplAuxBind _str env bndr new_rhs -- and more direct to focus on the "hot" cases. -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings | exprIsTrivial new_rhs -- Short-cut for let x = y in ... - || case (idOccInfo bndr) of - OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True - _ -> False +-- || case (idOccInfo bndr) of +-- OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True +-- _ -> False = return ( emptyFloats env , extendCvIdSubst env bndr new_rhs ) -- bndr can be a CoVar @@ -2361,8 +2361,9 @@ simplOutId env fun cont out_args = contOutArgs env cont :: [OutExpr] ; mb_match <- if not (null rules_for_me) && (isClassOpId fun || activeUnfolding (seMode env) fun) - then tryRules env rules_for_me fun out_args + then tryRules False env rules_for_me fun out_args else return Nothing + ; case mb_match of { Just (rule_arity, rhs) -> simplExprF env rhs $ dropContArgs rule_arity cont ; @@ -2455,7 +2456,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) = rebuild env (argInfoExpr fun rev_args) 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) + ; mb_match <- tryRules True env rules fun (map argSpecArg args) ; case mb_match of Just (rule_arity, rhs) -> simplExprF env rhs $ pushSimplifiedArgs env (drop rule_arity args) cont @@ -2641,17 +2642,20 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ -} -tryRules :: SimplEnv -> [CoreRule] - -> OutId -> [OutExpr] +tryRules :: Bool -- True <=> args are already simplified + -> SimplEnv -> [CoreRule] + -> OutId -> [CoreExpr] -> SimplM (Maybe (FullArgCount, CoreExpr)) -tryRules env rules fn args - | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env - act_fun fn args rules +tryRules args_are_simplified env rules fn args + | Just (RM { rm_rule = rule, rm_rhs = rule_rhs }) + <- -- pprTrace ("tryRules "++show args_are_simplified) (ppr fn) $ + 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 + ; let occ_anald_rhs | args_are_simplified = rule_rhs + | otherwise = occurAnalyseExpr rule_rhs -- See Note [Occurrence-analyse after rule firing] ; dump logger rule rule_rhs ; return (Just (ruleArity rule, occ_anald_rhs)) } @@ -2718,7 +2722,7 @@ trySeqRules :: SimplEnv trySeqRules in_env scrut rhs cont = do { rule_base <- getSimplRules ; let seq_rules = getRules rule_base seqId - ; mb_match <- tryRules in_env seq_rules seqId out_args + ; mb_match <- tryRules True in_env seq_rules seqId out_args ; case mb_match of Nothing -> return Nothing Just (rule_arity, rhs) -> return (Just (rhs, cont')) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1715,6 +1715,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs | n_br >= 100 -> False -- See #23627 | n_br == 1, NotInsideLam <- in_lam -- One syntactic occurrence + , unf_is_small -> True -- See Note [Post-inline for single-use things] -- | is_unlifted -- Unlifted binding, hence ok-for-spec @@ -1728,7 +1729,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs -- so inlining duplicates code but nothing more | otherwise - -> work_ok in_lam int_cxt && (n_br == 1 || smallEnoughToInline uf_opts unfolding) + -> work_ok in_lam int_cxt && ({- n_br == 1 || -} unf_is_small) -- Multiple syntactic occurences; but lazy, and small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true @@ -1740,6 +1741,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs _ -> False where + unf_is_small = smallEnoughToInline uf_opts unfolding + work_ok NotInsideLam _ = True work_ok IsInsideLam IsInteresting = isCheapUnfolding unfolding work_ok IsInsideLam NotInteresting = False ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1266,7 +1266,7 @@ fireRewriteRules :: SpecEnv -- Substitution is already zapped -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | let rules = getRules (se_rules env) f - , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules + , Just (RM { rm_rule = rule, rm_rhs = expr }) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] zapped_subst = se_subst env -- Just needed for the InScopeSet expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) @@ -1801,7 +1801,7 @@ alreadyCovered :: SpecEnv alreadyCovered env bndrs fn args is_active rules = case specLookupRule env fn args is_active rules of Nothing -> False - Just (rule, _) + Just (RM { rm_rule = rule }) | isAutoRule rule -> -- Discard identical rules -- We know that (fn args) is an instance of RULE -- Check if RULE is an instance of (fn args) @@ -1815,7 +1815,7 @@ alreadyCovered env bndrs fn args is_active rules specLookupRule :: HasDebugCallStack => SpecEnv -> Id -> [CoreExpr] -> (ActivationGhc -> Bool) -- Which rules are active - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + -> [CoreRule] -> Maybe RuleMatch specLookupRule env fn args is_active rules | null rules = Nothing -- Saves building a few thunks in the common case ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -10,6 +10,7 @@ module GHC.Core.Rules ( -- ** Looking up rules lookupRule, matchExprs, ruleLhsIsMoreSpecific, + RuleMatch(..), -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -542,6 +543,14 @@ map. ************************************************************************ -} +data RuleMatch = RM { rm_rule :: CoreRule + , rm_rhs :: CoreExpr } + -- Rule `rm_rule` matches, and the result is `rm_rhs` + -- + -- Example: RULE forall x y. f (g y x) = h [x,y] + -- If the target is (f (g e1 e2)), the RuleMatch has + -- rm_rhs = let {x = e1; y = e2 } in h [x,y] + -- | The main rule matching function. Attempts to apply all (active) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if @@ -552,7 +561,7 @@ lookupRule :: HasDebugCallStack -> Id -- Function head -> [CoreExpr] -- Args -> [CoreRule] -- Rules - -> Maybe (CoreRule, CoreExpr) + -> Maybe RuleMatch -- See Note [Extra args in the target] -- See comments on matchRule @@ -570,11 +579,11 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules args' = map (stripTicksTopE tickishFloatable) args ticks = concatMap (stripTicksTopT tickishFloatable) args - go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go :: [RuleMatch] -> [CoreRule] -> [RuleMatch] go ms [] = ms go ms (r:rs) - | Just e <- matchRule opts rule_env is_active fn args' rough_args r - = go ((r,mkTicks ticks e):ms) rs + | Just rhs <- matchRule opts rule_env is_active fn args' rough_args r + = go (RM { rm_rule = r, rm_rhs = mkTicks ticks rhs } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -584,15 +593,17 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules go ms rs findBest :: InScopeSet -> (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) + -> RuleMatch -> [RuleMatch] -> RuleMatch -- All these pairs matched the expression -- Return the pair the most specific rule -- The (fn,args) is just for overlap reporting -findBest _ _ (rule,ans) [] = (rule,ans) -findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) - | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs - | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs +findBest _ _ rm [] = rm +findBest in_scope target@(fn,args) + rm1@(RM { rm_rule = rule1 }) + (rm2@(RM { rm_rule = rule2 }) : prs) + | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target rm1 prs + | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target rm2 prs | debugIsOn = let pp_rule rule = ifPprDebug (ppr rule) (doubleQuotes (ftext (ruleName rule))) @@ -602,10 +613,8 @@ findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) <+> sep (map ppr args) , text "Rule 1:" <+> pp_rule rule1 , text "Rule 2:" <+> pp_rule rule2]) $ - findBest in_scope target (rule1,ans1) prs - | otherwise = findBest in_scope target (rule1,ans1) prs - where - (fn,args) = target + findBest in_scope target rm1 prs + | otherwise = findBest in_scope target rm1 prs ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool -- The call (rule1 `ruleIsMoreSpecific` rule2) @@ -684,7 +693,7 @@ matchRule :: HasDebugCallStack -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr --- If (matchRule rule args) returns Just (name,rhs) +-- If (matchRule rule args) returns Just rhs -- then (f args) matches the rule, and the corresponding -- rewritten RHS is rhs -- @@ -709,25 +718,31 @@ matchRule :: HasDebugCallStack -- NB: The 'surplus' argument e4 in the input is simply dropped. -- See Note [Extra args in the target] -matchRule opts rule_env _is_active fn args _rough_args +matchRule opts ise _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) - | not (roBuiltinRules opts) = Nothing - | otherwise = match_fn opts rule_env fn args -matchRule _ rule_env is_active _ args rough_args - (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops - , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) - | not (is_active act) = Nothing - | ruleCantMatch tpl_tops rough_args = Nothing - | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs + | roBuiltinRules opts = match_fn opts ise fn args + | otherwise = Nothing +matchRule _ ise is_active _ target_args rough_args + (Rule { ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | is_active act + , not (ruleCantMatch tpl_tops rough_args) + , Just (bind_wrapper, matched_es) <- matchExprs ise tpl_vars tpl_args target_args + = Just (bind_wrapper $ + mkLams tpl_vars rhs `mkApps` matched_es ) + -- NB: We cannot say: + -- mkLets [NonRec b e | (b,e) <- zip tpl_vars matched_es] rhs + -- because that brings tpl_vars into scope in a way that + -- shadows the matched_es. Bad bad. + | otherwise + = Nothing --------------------------------------- -matchN :: HasDebugCallStack - => InScopeEnv - -> RuleName -> [Var] -> [CoreExpr] - -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template - -> Maybe CoreExpr +matchExprs :: HasDebugCallStack + => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] + -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- @@ -737,15 +752,6 @@ matchN :: HasDebugCallStack -- If there are too /many/ actual arguments, we simply ignore the -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. - -matchN ise _rule_name tmpl_vars tmpl_es target_es rhs - = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } - -matchExprs :: HasDebugCallStack - => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] - -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) @@ -806,7 +812,7 @@ match_exprs :: HasDebugCallStack -> [CoreExpr] -- Targets -> Maybe RuleSubst -- If the targets are longer than templates, succeed, simply ignoring --- the leftover targets. This matters in the call in matchN. +-- the leftover targets. This matters in the call in matchExprs. -- -- Precondition: corresponding elements of es1 and es2 have the same -- type, assuming earlier elements match. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39d59acd7a8184ff7d68cb3e42c6102f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39d59acd7a8184ff7d68cb3e42c6102f... You're receiving this email because of your account on gitlab.haskell.org.