Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 1100029e by Simon Peyton Jones at 2026-04-13T00:09:18+01:00 More small wibbles The important change here is in preInlineUnconditionally - - - - - 3 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Ppr.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -283,7 +283,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs env + old_bndr NoDup rhs env = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) @@ -1298,7 +1298,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont do { ty' <- simplType env ty ; simplExprF (extendTvSubst env bndr ty') body cont } - | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + | Just env' <- preInlineUnconditionally env NotTopLevel bndr NoDup rhs env -- Because of the let-can-float invariant, it's ok to -- inline freely, or to drop the binding if it is dead. = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ @@ -1869,7 +1869,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se -- It's wrong to err in either direction -- But fun_ty is an OutType, so is fully substituted - ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se + ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr dup arg arg_se , not (needsCaseBindingL arg_levity arg) -- Ok to test arg::InExpr in needsCaseBinding because -- exprOkForSpeculation is stable under simplification @@ -2686,10 +2686,9 @@ tryRules env rules fn 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) + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName (rm_rule rule_match))) + ; dump logger rule_match ; return (Just rule_match) } | otherwise -- No rule fires @@ -2707,7 +2706,7 @@ tryRules env rules fn args (pprModuleName . moduleName) (ruleModule rule)) - dump logger rule rule_rhs + dump logger (RM { rm_rule = rule, rm_rhs = rhs, rm_args = rule_args }) | logHasDumpFlag logger Opt_D_dump_rule_rewrites = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat [ text "Rule:" <+> ftext (ruleName rule) @@ -2716,7 +2715,8 @@ tryRules env rules fn args --, text "Rule activation:" <+> ppr (ruleActivation rule) , text "Full arity:" <+> ppr (ruleArity rule) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs ] + , text "After:" <+> pprCoreExpr (mkApps rhs rule_args) + ] | logHasDumpFlag logger Opt_D_dump_rule_firings = log_rule Opt_D_dump_rule_firings "Rule fired:" $ @@ -3838,7 +3838,7 @@ knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont return ( emptyFloats env , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint)) - | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app env + | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr NoDup con_app env = return (emptyFloats env', env') | otherwise ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1565,13 +1565,13 @@ the former. preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together + -> DupFlag -> InExpr -> StaticEnv -- These three go together -> Maybe SimplEnv -- Returned env has extended substitution -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_env +preInlineUnconditionally env top_lvl bndr dup rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] @@ -1584,10 +1584,17 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- See Note [Stable unfoldings and preInlineUnconditionally] | not (isInlinePragma inline_prag) , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + | otherwise = Nothing where unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + + -- If the rhs is already simplified, then extend the envt with DoneEx; + -- If not then ContEx + -- ToDo: flesh this note out + extend_subst_with inl_rhs + | isSimplified dup = extendIdSubst env bndr $! DoneEx inl_rhs NotJoinPoint + | otherwise = extendIdSubst env bndr $! mkContEx rhs_env inl_rhs one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -430,19 +430,20 @@ pprTypedLamBinder bind_site debug_on var = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> case () of _ - | not debug_on -- Show case-bound wild binders only if debug is on + -- Show case-bound wild binders only if debug is on + | not debug_on , CaseBind <- bind_site - , isDeadBinder var -> empty + -> if isDeadBinder var + then empty + else pprUntypedBinder var + -- Show binders as "_" in case patterns + -- (but not in RULES or let) | not debug_on -- Even dead binders can be one-shot - , isDeadBinder var -> char '_' <+> ppWhen (isId var) - (pprIdBndrInfo (idInfo var)) - - | not debug_on -- No parens, no kind info - , CaseBind <- bind_site -> pprUntypedBinder var - - | not debug_on - , CasePatBind <- bind_site -> pprUntypedBinder var + , CasePatBind <- bind_site + -> if (isDeadBinder var) + then char '_' <+> ppWhen (isId var) (pprIdBndrInfo (idInfo var)) + else pprUntypedBinder var | suppress_sigs -> pprUntypedBinder var View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1100029edbec6fb6799a45cc28c9c3c6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1100029edbec6fb6799a45cc28c9c3c6... You're receiving this email because of your account on gitlab.haskell.org.