Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 6afeb99e by Simon Peyton Jones at 2026-04-06T23:59:01+01:00 Getting there [skip ci] - - - - - 6 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2294,11 +2294,12 @@ simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutEx simplOutExpr env expr cont = case fun of Var v -> simplOutId env v cont' - Lam {} | not (null args) -> simplLam env fun cont' -- We have a beta-redex + Lam {} | not (null args) -> simplLam env occ_fun cont' -- We have a beta-redex _ -> rebuild_go env expr cont where - (fun, args) <- collectArgs expr + (fun, args) = collectArgs expr cont' = pushArgs env Simplified (expType fun) args cont + occ_fun = occurAnalyseExpr fun -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] --------------------------------------------------------- simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2645,18 +2646,18 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity tryRules :: SimplEnv -> [CoreRule] -> OutId -> [OutExpr] - -> SimplM (Maybe (FullArgCount, CoreExpr)) + -> SimplM (Maybe (FullArgCount, CoreExpr, [CoreExpr])) tryRules env rules fn args - | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env - act_fun fn args rules + | 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] +-- ; let occ_anald_rhs = occurAnalyseExpr rule_rhs +-- -- See Note [Occurrence-analyse after rule firing] ; dump logger rule rule_rhs - ; return (Just (ruleArity rule, occ_anald_rhs)) } + ; return (Just (ruleArity rule, rhs_rhs, rule_args)) } | otherwise -- No rule fires = do { logger <- getLogger ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Core.Opt.Simplify.Utils ( -- The continuation type SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, - isSimplified, contIsStop, contHasArgs, + isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, countArgs, contOutArgs, dropContArgs, @@ -33,7 +33,7 @@ module GHC.Core.Opt.Simplify.Utils ( ArgInfo(..), ArgSpec(..), mkArgInfo, addValArgTo, addTyArgTo, argInfoExpr, argSpecArg, - pushSimplifiedArgs, pushArgSpecs, + pushArgs, pushArgSpecs, isStrictArgInfo, lazyArgContext, abstractFloats, @@ -389,13 +389,12 @@ pushArgs _env _dup _fun_ty [] cont = cont pushArgs env dup fun_ty (arg:args) cont | Type ty <- arg - = ApplyToType { sc_hole_ty = fun_ty - , sc_arg_ty = ty, sc_env = env - , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args } + = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty + , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args cont } | otherwise = ApplyToVal { sc_dup = dup, sc_hole_ty = fun_ty , sc_arg = arg, sc_env = env - , sc_cont = pushArgs env dup (funResultTy fun_ty) args } + , sc_cont = pushArgs env dup (funResultTy fun_ty) args cont} pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified -> [ArgSpec] -- In normal, forward order @@ -451,11 +450,6 @@ contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec contIsRhs (CastIt { sc_cont = k }) = contIsRhs k -- For f = e |> co, treat e as Rhs context contIsRhs _ = Nothing -------------------- -contHasArgs (ApplyToTy {}) = True -contHasArgs (ApplyToVal {}) = True -contHasArgs _ = False - ------------------- contIsStop :: SimplCont -> Bool contIsStop (Stop {}) = True ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2906,8 +2906,8 @@ betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) (CP { cp_qvars = vs2, cp_args = as2 }) | equalLength as1 as2 = case matchExprs ise vs1 as1 as2 of - Just (_, ms) -> all exprIsTrivial ms - Nothing -> False + Just (ms,_,_) -> all exprIsTrivial ms + Nothing -> False | otherwise -- We must handle patterns of unequal length separately (#24282) = False -- For the pattern with more args, the last arg is "interesting" ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -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 (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) @@ -1820,7 +1820,8 @@ specLookupRule env fn args is_active rules | null rules = Nothing -- Saves building a few thunks in the common case | otherwise - = lookupRule ropts in_scope_env is_active fn args rules + = case lookupRule ropts in_scope_env is_active fn args rules of + Just (rule, rule_rhs, rule_args) -> Just (rule, mkApps rule_rhs rule_args) where dflags = se_dflags env in_scope = substInScopeSet (se_subst env) ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( -- ** Looking up rules - lookupRule, matchExprs, ruleLhsIsMoreSpecific, + RuleMatch(..), lookupRule, matchExprs, ruleLhsIsMoreSpecific, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -542,6 +542,23 @@ map. ************************************************************************ -} +data RuleMatch + = RM { rm_rule :: CoreRule + , rm_rhs :: CoreExpr + , rm_args :: [CoreExpr] + , rm_binds :: BindWrapper -- Floated let-bindings + -- See Note [Matching lets] + , rm_bndrs :: [Var] -- Binders of rm_binds + } + -- E.g. match r = RULE forall x,y. f (Just (y,x)) = g x y True + -- target f (let v = ev in Just (ey, ex)) ez + -- We get the RuleMatch + -- RMM { rm_rule = r, rm_rhs = \xy. g x y True + -- , rm_args = [ex, ey] + -- , rm_binds = Let v=ev, rm_bndrs = [v] ) + -- The leftover `ez` is not returned; the caller is responsible for + -- counting (ruleArity r) arguments + -- | 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 +569,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 @@ -564,17 +581,17 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules where rough_args = map roughTopName args - -- Strip ticks from arguments, see Note [Tick annotations in RULE - -- matching]. We only collect ticks if a rule actually matches - + -- Strip ticks from arguments, see Note [Tick annotations in RULE matching] + -- We only collect ticks if a rule actually matches - -- this matters for performance tests. 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 rm <- matchRule opts rule_env is_active fn args' rough_args r + = go (rm { rm_binds = mkTicks ticks . rm_binds rm } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -583,35 +600,38 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules -- , isCheapUnfolding unf] ) go ms rs -findBest :: InScopeSet -> (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +findBest :: InScopeSet + -> (Id, [CoreExpr]) -- Target, just for overlap reporting + -> RuleMatch -- Most specific so far + -> [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 - | debugIsOn = let pp_rule rule +findBest _ _ rm [] = rm +findBest in_scope target rm1 (rm2: rms) + | ruleIsMoreSpecific in_scope rm1 rm2 = findBest in_scope target rm1 rms + | ruleIsMoreSpecific in_scope rm2 rm1 = findBest in_scope target rm2 rms + | debugIsOn = let pp_rule (RM { rm_rule = rule }) = ifPprDebug (ppr rule) (doubleQuotes (ftext (ruleName rule))) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" (vcat [ whenPprDebug $ text "Expression to match:" <+> ppr fn <+> 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 + , text "Rule 1:" <+> pp_rule rm1 + , text "Rule 2:" <+> pp_rule rm2]) $ + findBest in_scope target rm1 rms + | otherwise = findBest in_scope target rm1 rms where (fn,args) = target -ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool +ruleIsMoreSpecific :: InScopeSet -> RuleMatch -> RuleMatch -> Bool -- The call (rule1 `ruleIsMoreSpecific` rule2) -- sees if rule2 can be instantiated to look like rule1 -- See Note [ruleIsMoreSpecific] -ruleIsMoreSpecific in_scope rule1 rule2 +ruleIsMoreSpecific in_scope (RM { rm_rule = rule1 }) (RM { rm_rule = rule2 }) = case rule1 of BuiltinRule {} -> False Rule { ru_bndrs = bndrs1, ru_args = args1 } @@ -682,7 +702,7 @@ start, in general eta expansion wastes work. SLPJ July 99 matchRule :: HasDebugCallStack => RuleOpts -> InScopeEnv -> (ActivationGhc -> Bool) -> Id -> [CoreExpr] -> [Maybe Name] - -> CoreRule -> Maybe CoreExpr + -> CoreRule -> Maybe RuleMatch -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding @@ -708,26 +728,7 @@ 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 - (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 - - ---------------------------------------- -matchN :: HasDebugCallStack - => InScopeEnv - -> RuleName -> [Var] -> [CoreExpr] - -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template - -> Maybe CoreExpr +-- -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- @@ -738,24 +739,43 @@ matchN :: HasDebugCallStack -- 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) } +matchRule opts rule_env _is_active fn args _rough_args + rule@(BuiltinRule { ru_try = match_fn }) + = do { guard (roBuiltinRules opts) + ; rhs <- match_fn opts rule_env fn args + ; return (RM { rm_rule = rule + , rm_rhs = rhs + , rm_args = [] + , rm_binds = id + , rm_bndrs = [] }) } + +matchRule _opts rule_env is_active _fn target_es rough_args + rule@(Rule { 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 + = do { (matched_es, bind_wrapper, wrap_bndrs) + <- matchExprs rule_env tpl_vars tpl_args target_es + + ; return (RM { rm_rule = rule + , rm_rhs = mkLams tpl_vars rhs + , rm_args = matched_es + , rm_binds = bind_wrapper + , rm_bndrs = wrap_bndrs }) } matchExprs :: HasDebugCallStack => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] - -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] + -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] + , BindWrapper, [Var]) -- Floated binds 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) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - - ; let bind_wrapper = rs_binds rule_subst - -- Floated bindings; see Note [Matching lets] - - ; return (bind_wrapper, matched_es) } + ; return (matched_es, rs_binds rule_subst, rs_bndrs rule_subst) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] ===================================== utils/check-exact/Utils.hs ===================================== @@ -556,7 +556,7 @@ isSymbolRdrName n = isSymOcc $ rdrNameOcc n rdrName2String :: RdrName -> String rdrName2String r = - case isExact_maybe r of + case rdrNameExactName_maybe r of Just n -> name2String n Nothing -> case r of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6afeb99e9275295910474fa153bf6d1e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6afeb99e9275295910474fa153bf6d1e... You're receiving this email because of your account on gitlab.haskell.org.