[Git][ghc/ghc][wip/romes/25170-idea4] Do rules both before and after [skip ci]
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Mar 12 15:49:19 UTC 2025
Simon Peyton Jones pushed to branch wip/romes/25170-idea4 at Glasgow Haskell Compiler / GHC
Commits:
f5ebf251 by Simon Peyton Jones at 2025-03-12T15:45:13+00:00
Do rules both before and after [skip ci]
Before iff there is an active unfolding. But always after.
Consider not doing after if before fails. Typically if the
rule applies the unfolding is inactive
Goal (in T24984)
augment f (augment g (augment h (build k)))
-->
augment f (augment g (build..))
-->
augment f (build..)
-->
augment f (build..)
Want to do this in one pass.
Work in progress
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/CoreToStg/Prep.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -30,7 +30,7 @@ module GHC.Core.Opt.Simplify.Env (
-- * Simplifying 'Id' binders
simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
simplBinder, simplBinders,
- substTy, substTyVar, getSubst,
+ substTy, substTyVar, getFullSubst, getTCvSubst,
substCo, substCoVar,
-- * Floats
@@ -58,8 +58,9 @@ import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Rules.Config ( RuleOpts(..) )
import GHC.Core
import GHC.Core.Utils
+import GHC.Core.Subst( substExprSC )
import GHC.Core.Unfold
-import GHC.Core.TyCo.Subst (emptyIdSubstEnv)
+import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst)
import GHC.Core.Multiplicity( Scaled(..), mkMultMul )
import GHC.Core.Make ( mkWildValBinder, mkCoreLet )
import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo
@@ -1258,33 +1259,47 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca
************************************************************************
-}
-getSubst :: SimplEnv -> Subst
-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
- = mkTCvSubst in_scope tv_env cv_env
+getTCvSubst :: SimplEnv -> Subst
+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = mkSubst in_scope emptyVarEnv tv_env cv_env
+
+getFullSubst :: SimplEnv -> Subst
+getFullSubst (SimplEnv { seInScope = in_scope, seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })
+ = mk_full_subst in_scope tv_env cv_env id_env
+
+mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst
+mk_full_subst in_scope tv_env cv_env id_env
+ = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env
+ where
+ to_expr :: SimplSR -> CoreExpr
+ -- A tiresome impedence-matcher
+ to_expr (DoneEx e _) = e
+ to_expr (DoneId v) = Var v
+ to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e
substTy :: HasDebugCallStack => SimplEnv -> Type -> Type
-substTy env ty = Type.substTy (getSubst env) ty
+substTy env ty = Type.substTy (getTCvSubst env) ty
substTyVar :: SimplEnv -> TyVar -> Type
-substTyVar env tv = Type.substTyVar (getSubst env) tv
+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr env tv
- = case Type.substTyVarBndr (getSubst env) tv of
+ = case Type.substTyVarBndr (getTCvSubst env) tv of
(Subst in_scope' _ tv_env' cv_env', tv')
-> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
substCoVar :: SimplEnv -> CoVar -> Coercion
-substCoVar env tv = Coercion.substCoVar (getSubst env) tv
+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
substCoVarBndr env cv
- = case Coercion.substCoVarBndr (getSubst env) cv of
+ = case Coercion.substCoVarBndr (getTCvSubst env) cv of
(Subst in_scope' _ tv_env' cv_env', cv')
-> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
substCo :: SimplEnv -> Coercion -> Coercion
-substCo env co = Coercion.substCo (getSubst env) co
+substCo env co = Coercion.substCo (getTCvSubst env) co
------------------
substIdType :: SimplEnv -> Id -> Id
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1159,14 +1159,14 @@ simplExprF :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
simplExprF !env e !cont -- See Note [Bangs in the Simplifier]
- = {- pprTrace "simplExprF" (vcat
- [ ppr e
- , text "cont =" <+> ppr cont
- , text "inscope =" <+> ppr (seInScope env)
- , text "tvsubst =" <+> ppr (seTvSubst env)
- , text "idsubst =" <+> ppr (seIdSubst env)
- , text "cvsubst =" <+> ppr (seCvSubst env)
- ]) $ -}
+ = -- pprTrace "simplExprF" (vcat
+ -- [ ppr e
+ -- , text "cont =" <+> ppr cont
+ -- , text "inscope =" <+> ppr (seInScope env)
+ -- , text "tvsubst =" <+> ppr (seTvSubst env)
+ -- , text "idsubst =" <+> ppr (seIdSubst env)
+ -- , text "cvsubst =" <+> ppr (seCvSubst env)
+ -- ]) $
simplExprF1 env e cont
simplExprF1 :: HasDebugCallStack
@@ -1358,7 +1358,7 @@ simplCoercion env co
-- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env
; seqCo opt_co `seq` return opt_co }
where
- subst = getSubst env
+ subst = getTCvSubst env
opts = seOptCoercionOpts env
-----------------------------------
@@ -2261,11 +2261,64 @@ simplInId env var cont
---------------------------------------------------------
simplOutId :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+
+---------- The runRW# rule ------
+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.
+--
+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
+-- K[ runRW# @rr @hole_ty body ] --> runRW @rr' @ty' (\s. K[ body s ])
+simplOutId env fun cont
+ | fun `hasKey` runRWKey
+ , ApplyToTy { sc_cont = cont1 } <- cont
+ , ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1
+ , ApplyToVal { sc_cont = cont3, sc_arg = arg
+ , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2
+ -- Do this even if (contIsStop cont), or if seCaseCase is off.
+ -- See Note [No eta-expansion in runRW#]
+ = do { let arg_env = arg_se `setInScopeFromE` env
+
+ overall_res_ty = contResultType cont3
+ -- hole_ty is the type of the current runRW# application
+ (outer_cont, new_runrw_res_ty, inner_cont)
+ | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3)
+ | otherwise = (cont3, hole_ty, mkBoringStop hole_ty)
+ -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
+
+ -- If the argument is a literal lambda already, take a short cut
+ -- This isn't just efficiency:
+ -- * If we don't do this we get a beta-redex every time, so the
+ -- simplifier keeps doing more iterations.
+ -- * Even more important: see Note [No eta-expansion in runRW#]
+ ; arg' <- case arg of
+ Lam s body -> do { (env', s') <- simplBinder arg_env s
+ ; body' <- simplExprC env' body inner_cont
+ ; return (Lam s' body') }
+ -- Important: do not try to eta-expand this lambda
+ -- See Note [No eta-expansion in runRW#]
+
+ _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
+ ; let (m,_,_) = splitFunTy fun_ty
+ env' = arg_env `addNewInScopeIds` [s']
+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
+ , sc_env = env', sc_cont = inner_cont
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
+ -- cont' applies to s', then K
+ ; body' <- simplExprC env' arg cont'
+ ; return (Lam s' body') }
+
+ ; let rr' = getRuntimeRep new_runrw_res_ty
+ call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']
+ ; rebuild env call' outer_cont }
+
+
simplOutId env fun cont
= do { rule_base <- getSimplRules
; let rules_for_me = getRules rule_base fun
- ; mb_match <- tryRules zapped_env rules_for_me fun cont1
+ ; mb_match <- if activeUnfolding (seMode env) fun
+ then tryRules zapped_env rules_for_me fun cont1
+ else return Nothing
; case mb_match of {
Just (rhs, cont2) -> simplExprF zapped_env rhs cont2 ;
Nothing ->
@@ -2365,54 +2418,6 @@ rebuildCall env info (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })
rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })
= rebuildCall env (addTyArgTo info arg_ty hole_ty) cont
----------- The runRW# rule. Do this after absorbing all arguments ------
--- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.
---
--- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
--- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_cont = cont, sc_hole_ty = fun_ty })
- | fun_id `hasKey` runRWKey
- , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args
- -- Do this even if (contIsStop cont), or if seCaseCase is off.
- -- See Note [No eta-expansion in runRW#]
- = do { let arg_env = arg_se `setInScopeFromE` env
-
- overall_res_ty = contResultType cont
- -- hole_ty is the type of the current runRW# application
- (outer_cont, new_runrw_res_ty, inner_cont)
- | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)
- | otherwise = (cont, hole_ty, mkBoringStop hole_ty)
- -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
- -- Note [Case-of-case and full laziness]
-
- -- If the argument is a literal lambda already, take a short cut
- -- This isn't just efficiency:
- -- * If we don't do this we get a beta-redex every time, so the
- -- simplifier keeps doing more iterations.
- -- * Even more important: see Note [No eta-expansion in runRW#]
- ; arg' <- case arg of
- Lam s body -> do { (env', s') <- simplBinder arg_env s
- ; body' <- simplExprC env' body inner_cont
- ; return (Lam s' body') }
- -- Important: do not try to eta-expand this lambda
- -- See Note [No eta-expansion in runRW#]
-
- _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
- ; let (m,_,_) = splitFunTy fun_ty
- env' = arg_env `addNewInScopeIds` [s']
- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
- , sc_env = env', sc_cont = inner_cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
- -- cont' applies to s', then K
- ; body' <- simplExprC env' arg cont'
- ; return (Lam s' body') }
-
- ; let rr' = getRuntimeRep new_runrw_res_ty
- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']
- ; rebuild env call' outer_cont }
-
---------- Simplify value arguments --------------------
rebuildCall env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
@@ -2443,8 +2448,12 @@ 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 }) cont
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
+ | null rules
= rebuild env (argInfoExpr fun rev_args) cont
+ | otherwise -- Try rules again
+ = do { let args = argInfoAppArgs rev_args
+ ; mb_match <- tryRules env rules run args
-----------------------------------
tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)
@@ -2612,12 +2621,11 @@ tryRules env rules fn cont
| null rules
= return Nothing
- | Just (rule, rule_rhs) <- pprTrace "tryRules" (ppr fn) $
- lookupRule ropts (getUnfoldingInRuleMatch env)
- (activeRule (seMode env)) fn
- (contOutArgs cont) rules
+ | Just (rule, rule_rhs) <- -- pprTrace "tryRules" (ppr fn) $
+ lookupRule ropts in_scope_env
+ act_fun fn out_args rules
-- Fire a rule for the function
- = pprTrace "tryRules:success" (ppr fn) $
+ = -- pprTrace "tryRules:success" (ppr fn) $
do { logger <- getLogger
; checkedTick (RuleFired (ruleName rule))
; let cont' = dropContArgs (ruleArity rule) cont
@@ -2632,13 +2640,16 @@ tryRules env rules fn cont
-- hence zapping the environment
| otherwise -- No rule fires
- = pprTrace "tryRules:fail" (ppr fn) $
+ = -- pprTrace "tryRules:fail" (ppr fn) $
do { logger <- getLogger
; nodump logger -- This ensures that an empty file is written
; return Nothing }
where
- ropts = seRuleOpts env
+ ropts = seRuleOpts env :: RuleOpts
+ in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv
+ out_args = contOutArgs cont :: [OutExpr]
+ act_fun = activeRule (seMode env) :: Activation -> Bool
printRuleModule rule
= parens (maybe (text "BUILTIN")
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -85,7 +85,6 @@ import Control.Monad ( when )
import Data.List ( sortBy )
import GHC.Types.Name.Env
import Data.Graph
-import Data.Maybe
{- *********************************************************************
* *
@@ -283,9 +282,9 @@ instance Outputable SimplCont where
= (text "TickIt" <+> ppr t) $$ ppr cont
ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })
= (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
- ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })
- = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)
- 2 (pprParendExpr arg))
+ ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty, sc_env = env })
+ = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)
+ 2 (ppr (seIdSubst env) $$ pprParendExpr arg))
$$ ppr cont
ppr (StrictBind { sc_bndr = b, sc_cont = cont })
= (text "StrictBind" <+> ppr b) $$ ppr cont
@@ -326,9 +325,10 @@ data ArgInfo
ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order)
-- NB: all these argumennts are already simplified
- ai_rewrite :: RewriteCall, -- What transformation to try next for this call
- -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration
+-- ai_rewrite :: RewriteCall, -- What transformation to try next for this call
+-- -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration
+ ai_rules :: [CoreRule], -- Rules for this function
ai_encl :: Bool, -- Flag saying whether this function
-- or an enclosing one has rules (recursively)
-- True => be keener to inline in all args
@@ -596,7 +596,8 @@ contOutArgs (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = co
| isSimplified dup
= arg : contOutArgs cont
| otherwise
- = GHC.Core.Subst.substExprSC (getSubst env) arg : contOutArgs cont
+ = -- pprTrace "contOutArgs" (ppr arg $$ ppr (seIdSubst env)) $
+ GHC.Core.Subst.substExprSC (getFullSubst env) arg : contOutArgs cont
contOutArgs _
= []
@@ -642,20 +643,19 @@ mkArgInfo :: SimplEnv -> [CoreRule] -> Id -> SimplCont -> ArgInfo
mkArgInfo env rules_for_fun fun cont
| n_val_args < idArity fun -- Note [Unsaturated functions]
= ArgInfo { ai_fun = fun, ai_args = []
- , ai_rewrite = fun_rewrite
+ , ai_rules = rules_for_fun
, ai_encl = False
, ai_dmds = vanilla_dmds
, ai_discs = vanilla_discounts }
| otherwise
= ArgInfo { ai_fun = fun
, ai_args = []
- , ai_rewrite = fun_rewrite
+ , ai_rules = rules_for_fun
, ai_encl = fun_has_rules || contHasRules cont
, ai_dmds = add_type_strictness (idType fun) arg_dmds
, ai_discs = arg_discounts }
where
n_val_args = countValArgs cont
- fun_rewrite = TryNothing
fun_has_rules = not (null rules_for_fun)
@@ -1474,10 +1474,6 @@ preInlineUnconditionally
-- 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
- = pprTrace "preInlineUnconditionally" (ppr bndr <+> ppr (isJust res)) $
- res
- where
- res
| not pre_inline_unconditionally = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -239,11 +239,7 @@ substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
-- their canonical representatives in the in-scope set
substExprSC subst orig_expr
| isEmptySubst subst = orig_expr
- | otherwise = pprTrace "enter subst-expr" (ppr subst $$ ppr orig_expr) $
- pprTrace "result subst-expr" (ppr res) $
- res
- where
- res = substExpr subst orig_expr
+ | otherwise = substExpr subst orig_expr
-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember,
-- you may only apply the substitution /once/:
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -13,7 +13,7 @@ module GHC.Core.TyCo.Subst
Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,
emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,
emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,
- mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,
+ mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,
getTvSubstEnv, getIdSubstEnv,
getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs,
isInScope, elemSubst, notElemSubst, zapSubst,
@@ -273,6 +273,9 @@ isEmptyTCvSubst :: Subst -> Bool
isEmptyTCvSubst (Subst _ _ tv_env cv_env)
= isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
+mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst
+mkSubst = Subst
+
mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1492,7 +1492,6 @@ The former had the CPR property, and so should the latter.
Other considered designs
------------------------
-
One design that was rejected was to *require* that runRW#'s continuation be
headed by a lambda. However, this proved to be quite fragile. For instance,
SetLevels is very eager to float bottoming expressions. For instance given
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5ebf251ef975b977d1772fe679a499479010f92
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5ebf251ef975b977d1772fe679a499479010f92
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250312/a4086bc9/attachment-0001.html>
More information about the ghc-commits
mailing list