[Git][ghc/ghc][wip/romes/25170-idea4] MOre...
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Mar 13 17:29:36 UTC 2025
Simon Peyton Jones pushed to branch wip/romes/25170-idea4 at Glasgow Haskell Compiler / GHC
Commits:
25caf4d3 by Simon Peyton Jones at 2025-03-13T17:29:09+00:00
MOre...
- - - - -
3 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1335,7 +1335,7 @@ isAutoRule (Rule { ru_auto = is_auto }) = is_auto
-- | The number of arguments the 'ru_fn' must be applied
-- to before the rule can match on it
-ruleArity :: CoreRule -> Int
+ruleArity :: CoreRule -> FullArgCount
ruleArity (BuiltinRule {ru_nargs = n}) = n
ruleArity (Rule {ru_args = args}) = length args
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -799,8 +799,8 @@ makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats,
makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })
= do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e
; return (floats, arg { as_arg = e' }) }
-makeTrivialArg _ arg
- = return (emptyLetFloats, arg) -- CastBy, TyArg
+makeTrivialArg _ arg@(TyArg {})
+ = return (emptyLetFloats, arg)
makeTrivial :: HasDebugCallStack
=> SimplEnv -> TopLevelFlag -> Demand
@@ -1520,12 +1520,11 @@ simplTick env tickish expr cont
-}
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
--- At this point the substitution in the SimplEnv is irrelevant;
--- only the in-scope set matters, plus the flags.
--- So zap it before calling `rebuild_go`
rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont
rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;
+-- only the in-scope set matters, plus the flags.
rebuild_go env expr cont
= assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $
case cont of
@@ -2323,18 +2322,19 @@ simplOutId env fun cont
simplOutId env fun cont
- = do { rule_base <- getSimplRules
- ; let rules_for_me = getRules rule_base fun
+ = do { let cont1 = trimJoinCont fun (idJoinPointHood fun) cont
- ; mb_match <- -- if activeUnfolding (seMode env) fun
- -- then
- -- else return Nothing
- tryRules zapped_env rules_for_me fun cont1
+ -- Try rewrite rules
+ ; rule_base <- getSimplRules
+ ; let rules_for_me = getRules rule_base fun
+ out_args = contOutArgs env cont1 :: [OutExpr]
+ ; mb_match <- tryRules zapped_env rules_for_me fun out_args
; case mb_match of {
- Just (rhs, cont2) -> -- pprTrace "tryRules1" (ppr fun) $
- simplExprF zapped_env rhs cont2 ;
+ Just (rule_arity, rhs) -> simplExprF zapped_env rhs $
+ dropContArgs rule_arity cont1 ;
Nothing ->
+ -- Try inlining
do { logger <- getLogger
; mb_inline <- tryInlining env logger fun cont1
; case mb_inline of{
@@ -2342,19 +2342,19 @@ simplOutId env fun cont
; simplExprF zapped_env expr cont1 } ;
Nothing ->
- do { let arg_info = mkArgInfo env rules_for_me fun cont1
+ -- Neither worked, so just rebuild
+ do { let arg_info = mkArgInfo env fun rules_for_me cont1
; rebuildCall zapped_env arg_info cont1
} } } } }
where
zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
- cont1 = trimJoinCont fun (idJoinPointHood fun) cont
---------------------------------------------------------
-- Dealing with a call site
rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont
-> SimplM (SimplFloats, OutExpr)
--- At this point the substitution in the SimplEnv is irrelevant;
+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;
-- it is usually empty, and regardless should be ignored.
-- Only the in-scope set matters, plus the seMode flags
@@ -2384,57 +2384,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) con
res = argInfoExpr fun rev_args
cont_ty = contResultType cont
-{-
----------- Try inlining, if ai_rewrite = TryInlining --------
--- In the TryInlining case we try inlining immediately, before simplifying
--- any (more) arguments. Why? See Note [Rewrite rules and inlining].
---
--- If there are rewrite rules we'll skip this case until we have
--- simplified enough args to satisfy nr_wanted==0 in the TryRules case below
--- Then we'll try the rules, and if that fails, we'll do TryInlining
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
- , ai_rewrite = TryInlining }) cont
- = do { logger <- getLogger
- ; let full_cont = pushSimplifiedRevArgs env rev_args cont
- ; mb_inline <- tryInlining env logger fun full_cont
- ; case mb_inline of
- Just expr -> do { checkedTick (UnfoldingDone fun)
- ; let env1 = zapSubstEnv env
- ; simplExprF env1 expr full_cont }
- Nothing -> rebuildCall env (info { ai_rewrite = TryNothing }) cont
- }
--}
-
-{-
----------- Try rewrite RULES, if ai_rewrite = TryRules --------------
--- See Note [Rewrite rules and inlining]
--- See also Note [Trying rewrite rules]
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
- , ai_rewrite = TryRules rules }) cont
- | no_more_args
- = -- We've accumulated a simplified call in <fun,rev_args>
- -- so try rewrite rules; see Note [RULES apply to simplified arguments]
- -- See also Note [Rules for recursive functions]
- do { mb_match <- tryRules env rules fun (reverse rev_args) cont
- ; case mb_match of
- Just (env', rhs, cont') -> simplExprF env' rhs cont'
- Nothing -> rebuildCall env (info { ai_rewrite = TryInlining }) cont }
- where
- -- If we have run out of arguments, just try the rules; there might
- -- be some with lower arity. Casts get in the way -- they aren't
- -- allowed on rule LHSs
- no_more_args = case cont of
- ApplyToTy {} -> False
- ApplyToVal {} -> False
- _ -> True
--}
-
----------- Simplify type applications and casts --------------
-rebuildCall env info (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })
- = rebuildCall env (addCastTo info co') cont
- where
- co' = optOutCoercion env co opt
-
+---------- Simplify type applications --------------
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
@@ -2472,11 +2422,11 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules })
| null rules
= rebuild env (argInfoExpr fun rev_args) cont
| otherwise -- Try rules again
- = do { let full_cont = pushSimplifiedRevArgs env rev_args cont
- ; mb_match <- tryRules env rules fun full_cont
+ = do { let args = reverse rev_args
+ ; mb_match <- tryRules env rules fun (map argSpecArg args)
; case mb_match of
- Just (rhs, cont2) -> -- pprTrace "tryRules2" (ppr fun $$ ppr (seIdSubst env)) $
- simplExprF env rhs cont2
+ Just (rule_arity, rhs) -> simplExprF env rhs $
+ pushSimplifiedArgs env (drop rule_arity args) cont
Nothing -> rebuild env (argInfoExpr fun rev_args) cont }
-----------------------------------
@@ -2637,31 +2587,24 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity
-}
tryRules :: SimplEnv -> [CoreRule]
- -> OutId
- -> SimplCont
- -> SimplM (Maybe (CoreExpr, SimplCont))
+ -> OutId -> [OutExpr]
+ -> SimplM (Maybe (FullArgCount, CoreExpr))
-tryRules env rules fn cont
+tryRules env rules fn args
| null rules
= return Nothing
| Just (rule, rule_rhs) <- -- pprTrace "tryRules" (ppr fn <+> vcat (map ppr out_args)) $
lookupRule ropts in_scope_env
- act_fun fn out_args rules
+ act_fun fn args rules
-- Fire a rule for the function
= -- pprTrace "tryRules:success" (ppr fn) $
do { logger <- getLogger
; checkedTick (RuleFired (ruleName rule))
- ; let cont' = dropContArgs (ruleArity rule) cont
- -- (ruleArity rule) says how
- -- many args the rule consumed
-
- occ_anald_rhs = occurAnalyseExpr rule_rhs
+ ; let occ_anald_rhs = occurAnalyseExpr rule_rhs
-- See Note [Occurrence-analyse after rule firing]
; dump logger rule rule_rhs
- ; return (Just (occ_anald_rhs, cont')) }
- -- The occ_anald_rhs and cont' are all Out things
- -- hence zapping the environment
+ ; return (Just (ruleArity rule, occ_anald_rhs)) }
| otherwise -- No rule fires
= -- pprTrace "tryRules:fail" (ppr fn) $
@@ -2672,7 +2615,6 @@ tryRules env rules fn cont
where
ropts = seRuleOpts env :: RuleOpts
in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv
- out_args = contOutArgs (seInScope env) cont :: [OutExpr]
act_fun = activeRule (seMode env) :: Activation -> Bool
printRuleModule rule
@@ -2686,7 +2628,7 @@ tryRules env rules fn cont
[ text "Rule:" <+> ftext (ruleName rule)
, text "Module:" <+> printRuleModule rule
, text "Full arity:" <+> ppr (ruleArity rule)
- , text "Before:" <+> hang (ppr fn) 2 (ppr cont)
+ , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
, text "After: " <+> pprCoreExpr rule_rhs ]
| logHasDumpFlag logger Opt_D_dump_rule_firings
@@ -2725,9 +2667,14 @@ trySeqRules :: SimplEnv
trySeqRules in_env scrut rhs cont
= do { rule_base <- getSimplRules
; let seq_rules = getRules rule_base seqId
- ; tryRules out_env seq_rules seqId rule_cont }
+ ; mb_match <- tryRules in_env seq_rules seqId out_args
+ ; case mb_match of
+ Nothing -> return Nothing
+ Just (rule_arity, rhs) -> return (Just (rhs, cont'))
+ where
+ cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont
+ }
where
- out_env = zapSubstEnv in_env
no_cast_scrut = drop_casts scrut
-- All these are OutTypes
@@ -2740,16 +2687,22 @@ trySeqRules in_env scrut rhs cont
rhs_ty = substTy in_env (exprType rhs)
rhs_rep = getRuntimeRep rhs_ty
- rule_cont = ApplyToTy { sc_arg_ty = rhs_rep, sc_hole_ty = seq_id_ty, sc_cont = rule_cont1 }
- rule_cont1 = ApplyToTy { sc_arg_ty = scrut_ty, sc_hole_ty = res1_ty, sc_cont = rule_cont2 }
- rule_cont2 = ApplyToTy { sc_arg_ty = rhs_ty, sc_hole_ty = res2_ty, sc_cont = rule_cont3 }
- rule_cont3 = ApplyToVal { sc_arg = no_cast_scrut, sc_hole_ty = res3_ty, sc_cont = rule_cont4
- , sc_dup = Simplified, sc_env = out_env }
- rule_cont4 = ApplyToVal { sc_arg = rhs, sc_hole_ty = res4_ty, sc_cont = cont
- , sc_dup = NoDup, sc_env = in_env }
+ out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut]
+ -- Cheaper than (map argSpecArg out_arg_specs)
+ out_arg_specs = [ TyArg { as_arg_ty = rhs_rep
+ , as_hole_ty = seq_id_ty }
+ , TyArg { as_arg_ty = scrut_ty
+ , as_hole_ty = res1_ty }
+ , TyArg { as_arg_ty = rhs_ty
+ , as_hole_ty = res2_ty }
+ , ValArg { as_arg = no_cast_scrut
+ , as_dmd = seqDmd
+ , as_hole_ty = res3_ty } ]
+ rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
+ , sc_env = in_env, sc_cont = cont
+ , sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
-
drop_casts (Cast e _) = drop_casts e
drop_casts e = e
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -30,9 +30,9 @@ module GHC.Core.Opt.Simplify.Utils (
interestingCallContext,
-- ArgInfo
- ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo,
- addValArgTo, addCastTo, addTyArgTo,
- argInfoExpr, argInfoAppArgs,
+ ArgInfo(..), ArgSpec(..), mkArgInfo,
+ addValArgTo, addTyArgTo,
+ argInfoExpr, argSpecArg,
pushSimplifiedArgs, pushSimplifiedRevArgs,
isStrictArgInfo, lazyArgContext,
@@ -325,11 +325,8 @@ 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_rules :: [CoreRule], -- Rules for this function
- ai_encl :: Bool, -- Flag saying whether 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
@@ -343,12 +340,6 @@ data ArgInfo
-- Always infinite
}
-data RewriteCall -- What rewriting to try next for this call
- -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration
- = TryRules [CoreRule]
- | TryInlining
- | TryNothing
-
data ArgSpec
= ValArg { as_dmd :: Demand -- Demand placed on this argument
, as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
@@ -357,9 +348,6 @@ data ArgSpec
| TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy
, as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah)
- | CastBy OutCoercion -- Cast by this; c.f. CastIt
- -- Coercion is optimised
-
instance Outputable ArgInfo where
ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })
= text "ArgInfo" <+> braces
@@ -370,7 +358,6 @@ instance Outputable ArgInfo where
instance Outputable ArgSpec where
ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
- ppr (CastBy c) = text "CastBy" <+> ppr c
addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
addValArgTo ai arg hole_ty
@@ -389,21 +376,12 @@ addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai }
where
arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
-addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }
-
isStrictArgInfo :: ArgInfo -> Bool
-- True if the function is strict in the next argument
isStrictArgInfo (ArgInfo { ai_dmds = dmds })
| dmd:_ <- dmds = isStrUsedDmd dmd
| otherwise = False
-argInfoAppArgs :: [ArgSpec] -> [OutExpr]
-argInfoAppArgs [] = []
-argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast
-argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as
-argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as
-
pushSimplifiedArgs, pushSimplifiedRevArgs
:: SimplEnv
-> [ArgSpec] -- In normal, forward order for pushSimplifiedArgs,
@@ -419,8 +397,10 @@ pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
= ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
-- The SubstEnv will be ignored since sc_dup=Simplified
, sc_hole_ty = hole_ty, sc_cont = cont }
-pushSimplifiedArg _ (CastBy c) cont
- = CastIt { sc_co = c, sc_cont = cont, sc_opt = True }
+
+argSpecArg :: ArgSpec -> OutExpr
+argSpecArg (ValArg { as_arg = arg }) = arg
+argSpecArg (TyArg { as_arg_ty = ty }) = Type ty
argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
-- NB: the [ArgSpec] is reversed so that the first arg
@@ -431,25 +411,6 @@ argInfoExpr fun rev_args
go [] = Var fun
go (ValArg { as_arg = arg } : as) = go as `App` arg
go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty
- go (CastBy co : as) = mkCast (go as) co
-
-{-
-mkRewriteCall :: Id -> RuleEnv -> RewriteCall
--- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration
--- We try to skip any unnecessary stages:
--- No rules => skip TryRules
--- No unfolding => skip TryInlining
--- This skipping is "just" for efficiency. But rebuildCall is
--- quite a heavy hammer, so skipping stages is a good plan.
--- And it's extremely simple to do.
-mkRewriteCall fun rule_env
- | not (null rules) = TryRules rules
- | canUnfold unf = TryInlining
- | otherwise = TryNothing
- where
- rules = getRules rule_env fun
- unf = idUnfolding fun
--}
{-
************************************************************************
@@ -588,20 +549,24 @@ contArgs cont
-- Do *not* use short-cutting substitution here
-- because we want to get as much IdInfo as possible
-contOutArgs :: GHC.Core.Subst.InScopeSet -> SimplCont -> [OutExpr]
+contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]
-- Get the leading arguments from the `SimplCont`, as /OutExprs/
-contOutArgs in_scope (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })
- = Type ty : contOutArgs in_scope cont
-contOutArgs in_scope (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })
- | isSimplified dup
- = arg : contOutArgs in_scope cont
- | otherwise
- = -- pprTrace "contOutArgs" (ppr arg $$ ppr (seIdSubst env)) $
- GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : contOutArgs in_scope cont
- -- NOT substExprSC: we want to get the benefit of knowing what is
- -- evaluated etc, via the in-scope set
-contOutArgs _ _
- = []
+contOutArgs env cont
+ = go cont
+ where
+ in_scope = seInScope env
+
+ go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })
+ = Type ty : go cont
+
+ go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })
+ | isSimplified dup = arg : go cont
+ | otherwise = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont
+ -- NOT substExprSC: we want to get the benefit of knowing what is
+ -- evaluated etc, via the in-scope set
+
+ -- No more arguments
+ go _ = []
dropContArgs :: FullArgCount -> SimplCont -> SimplCont
dropContArgs 0 cont = cont
@@ -640,9 +605,8 @@ contEvalContext k = case k of
-- and case binder dmds, see addCaseBndrDmd. No priority right now.
-------------------
-mkArgInfo :: SimplEnv -> [CoreRule] -> Id -> SimplCont -> ArgInfo
-
-mkArgInfo env rules_for_fun fun cont
+mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo
+mkArgInfo env fun rules_for_fun cont
| n_val_args < idArity fun -- Note [Unsaturated functions]
= ArgInfo { ai_fun = fun, ai_args = []
, ai_rules = rules_for_fun
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25caf4d3393a759e1cbe0cc37a89c9ca4aa116e1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25caf4d3393a759e1cbe0cc37a89c9ca4aa116e1
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/20250313/b1efed16/attachment-0001.html>
More information about the ghc-commits
mailing list