[Git][ghc/ghc][wip/romes/25170] 2 commits: WIP where tryRules receives cont.
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Aug 21 11:30:31 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/25170 at Glasgow Haskell Compiler / GHC
Commits:
95d2d9dd by Rodrigo Mesquita at 2024-08-20T13:36:11+01:00
WIP where tryRules receives cont.
- - - - -
0deea9fa by Rodrigo Mesquita at 2024-08-21T12:30:19+01:00
WIP Progress
- - - - -
4 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/Rules.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -939,7 +939,7 @@ So we want to look up the inner X.g_34 in the substitution, where we'll
find that it has been substituted by b. (Or conceivably cloned.)
-}
-substId :: SimplEnv -> InId -> SimplSR
+substId :: HasDebugCallStack => SimplEnv -> InId -> SimplSR
-- Returns DoneEx only on a non-Var expression
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
= case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
@@ -953,7 +953,7 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
--
-- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify.
-refineFromInScope :: InScopeSet -> Var -> Var
+refineFromInScope :: HasDebugCallStack => InScopeSet -> Var -> Var
refineFromInScope in_scope v
| isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
@@ -961,7 +961,7 @@ refineFromInScope in_scope v
-- c.f #19074 for a subtle place where this went wrong
| otherwise = v
-lookupRecBndr :: SimplEnv -> InId -> OutId
+lookupRecBndr :: HasDebugCallStack => SimplEnv -> InId -> OutId
-- Look up an Id which has been put into the envt by simplRecBndrs,
-- but where we have not yet done its RHS
lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1156,7 +1156,8 @@ simplExprC env expr cont
return (wrapFloats floats expr') }
--------------------------------------------------
-simplExprF :: SimplEnv
+simplExprF :: HasDebugCallStack
+ => SimplEnv
-> InExpr -- A term-valued expression, never (Type ty)
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
@@ -2233,7 +2234,7 @@ simplVar env var
DoneId var1 -> return (Var var1)
DoneEx e _ -> return e
-simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+simplIdF :: HasDebugCallStack => SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplIdF env var cont
| isDataConWorkId var -- See Note [Fast path for data constructors]
= rebuild env (Var var) cont
@@ -2306,20 +2307,26 @@ rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
-- See Note [Rewrite rules and inlining]
-- See also Note [Trying rewrite rules]
rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
- , ai_dmds = dms, ai_rewrite = TryRules rules }) cont
+ , ai_rewrite = TryRules have_tried_unsimp rules }) cont
-- romes:todo: note on trying rules twice: one on unsimplified args, the other on simplified args.
- | null rev_args || no_more_args
+ | {- pprTrace "rebuildTryRules" (ppr fun <+> ppr rev_args) $ -}
+ null rev_args || no_more_args
= -- We try rules twice: once on unsimplified args and once after
-- we've accumulated a simplified call in <fun,rev_args>
-- See Note [RULES apply to simplified arguments] (TODO: EDIT NOTE AND TITLE)
-- See also Note [Rules for recursive functions]
- do { let (rules_args, cont')
- | null rev_args = contArgsSpec dms cont -- Unsimplified args
- | otherwise = (reverse rev_args, cont) -- Simplified args
- ; mb_match <- tryRules env rules fun rules_args cont'
+ --
+ -- tryRules will take arguments from the continuation as needed if already
+ -- simplified args (rev_args) are not enough.
+ 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 }
+ Just (env', rhs, cont') -> simplExprF env' rhs cont'
+ Nothing -> rebuildCall env (info
+ { ai_rewrite =
+ if have_tried_unsimp || no_more_args
+ then TryInlining
+ else TryRules True rules {- try once again after simplifying args -}
+ }) 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
@@ -2579,25 +2586,35 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity
************************************************************************
-}
-tryRules :: SimplEnv -> [CoreRule]
- -> Id
- -> [ArgSpec] -- In /normal, forward/ order
- -> SimplCont
+-- | 'tryRules' will try to apply a rule from the given rules to an application
+-- of function to N arguments, where N is the arity of the rule.
+--
+-- Note that there may not be enough simplified arguments @[ArgSpec]@ to
+-- satisfy the rule arity, thus 'tryRules' will look into the continuation for
+-- the remaining unsimplified arguments needed.
+--
+-- See also Note [Try RULES twice: on unsimplified and simplified args]
+tryRules :: SimplEnv
+ -> [CoreRule] -- ^ List of rules to try
+ -> Id -- ^ Function identifier
+ -> [ArgSpec] -- ^ Simplified function arguments in /normal, forward/ order
+ -> SimplCont -- ^ The continuation (note: may contain more, unsimplified,
+ -- function arguments, if the simplified ones are not enough)
-> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
-
tryRules env rules fn args call_cont
| null rules
= return Nothing
- | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)
+ | Just (rule, rule_rhs) <- {- pprTrace "tryRules" (ppr (argInfoAppArgs args ++ contArgs call_cont)) $ -}
+ lookupRule ropts (getUnfoldingInRuleMatch env)
(activeRule (seMode env)) fn
- (argInfoAppArgs args) rules
+ (argInfoAppArgs args ++ contArgs call_cont) rules
-- Fire a rule for the function
= do { logger <- getLogger
; checkedTick (RuleFired (ruleName rule))
; let cont' = pushSimplifiedArgs zapped_env
(drop (ruleArity rule) args)
- call_cont
+ (contDropArgs (ruleArity rule - min (ruleArity rule) (length args)) call_cont)
-- (ruleArity rule) says how
-- many args the rule consumed
@@ -2614,6 +2631,7 @@ tryRules env rules fn args call_cont
; return Nothing }
where
+
ropts = seRuleOpts env
zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
@@ -2625,7 +2643,7 @@ tryRules env rules fn args call_cont
dump logger rule rule_rhs
| logHasDumpFlag logger Opt_D_dump_rule_rewrites
= log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat
- [ text "Rule:" <+> ftext (ruleName rule)
+ [ text "Rule:" <+> ppr (rule)
, text "Module:" <+> printRuleModule rule
, text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
, text "After: " <+> hang (pprCoreExpr rule_rhs) 2
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils (
SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
- contIsTrivial, contArgsSpec, contArgsSummary, contIsRhs,
+ contIsTrivial, contArgs, contDropArgs, contArgsSummary, contIsRhs,
countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop,
interestingCallContext,
@@ -72,6 +72,7 @@ import GHC.Types.Id.Info
import GHC.Types.Tickish
import GHC.Types.Demand
import GHC.Types.Var.Set
+import GHC.Types.Var.Env ( isEmptyVarEnv )
import GHC.Types.Basic
import GHC.Data.OrdList ( isNilOL )
@@ -83,7 +84,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Monad ( when )
-import Data.Bifunctor ( first )
import Data.List ( sortBy )
import GHC.Types.Name.Env
import Data.Graph
@@ -345,7 +345,10 @@ data ArgInfo
data RewriteCall -- What rewriting to try next for this call
-- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration
- = TryRules [CoreRule]
+ = TryRules
+ Bool -- True if these rules have already been tried on unsimplified arguments
+ -- See Note [Try rules twice in one pass]
+ [CoreRule]
| TryInlining
| TryNothing
@@ -444,7 +447,7 @@ mkRewriteCall :: Id -> RuleEnv -> RewriteCall
-- 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
+ | not (null rules) = TryRules False rules
| canUnfold unf = TryInlining
| otherwise = TryNothing
where
@@ -565,19 +568,29 @@ countValArgs (CastIt { sc_cont = cont }) = countValArgs cont
countValArgs _ = 0
-------------------
-
--- | Get the ArgSpecs of the continuation arguments given the function demands.
--- The returned continuation is stripped of the args.
-contArgsSpec :: [Demand] -> SimplCont -> ([ArgSpec], SimplCont)
-contArgsSpec ds (ApplyToTy { sc_arg_ty = arg
- , sc_hole_ty = hole
- , sc_cont = cont }) = first (TyArg arg hole :) (contArgsSpec ds cont)
-contArgsSpec (d:ds) (ApplyToVal
- { sc_arg = arg
- , sc_hole_ty = hole
- , sc_cont = cont }) = first (ValArg d arg hole :) (contArgsSpec ds cont)
-contArgsSpec ds (CastIt { sc_cont = cont }) = contArgsSpec ds cont
-contArgsSpec _ cont = ([], cont)
+-- | Get the immediately available independent arguments out of the continuation.
+-- This means if we find some argument that depends on an idsubst we don't include it in the result and stop.
+-- Casts also stop the argument retrieval...
+contArgs :: SimplCont -> [CoreExpr]
+contArgs (ApplyToTy { sc_arg_ty = arg
+ , sc_cont = cont })
+ = Type arg : (contArgs cont)
+contArgs (ApplyToVal { sc_arg = arg
+ , sc_env = env
+ , sc_cont = cont })
+ | isEmptyVarEnv (seIdSubst env) -- could we not be a bit smarter? for example, apply the substitution straight away eg if the arg is just a single var?
+ = arg : (contArgs cont)
+ | otherwise
+ = []
+-- contArgs (CastIt { sc_cont = cont }) = contArgs cont
+contArgs _cont = []
+
+-- | Drops N arguments from the continuation or until there are no more args.
+contDropArgs :: Int -> SimplCont -> SimplCont
+contDropArgs 0 cont = cont
+contDropArgs n (ApplyToTy { sc_cont = cont }) = contDropArgs (n-1) cont
+contDropArgs n (ApplyToVal { sc_cont = cont }) = contDropArgs (n-1) cont
+contDropArgs _n cont = cont
contArgsSummary :: SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Summarises value args, discards type args and coercions
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -539,10 +539,10 @@ map.
-- context, returning the rule applied and the resulting expression if
-- successful.
lookupRule :: RuleOpts -> InScopeEnv
- -> (Activation -> Bool) -- When rule is active
- -> Id -- Function head
- -> [CoreExpr] -- Args
- -> [CoreRule] -- Rules
+ -> (Activation -> Bool) -- ^ When rule is active
+ -> Id -- ^ Function head
+ -> [CoreExpr] -- ^ Args
+ -> [CoreRule] -- ^ Rules
-> Maybe (CoreRule, CoreExpr)
-- See Note [Extra args in the target]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/346f8a6912f4b5702b987cbb20f08fc87e6f5a46...0deea9fa0c1dd7c474827f64d17f0d19a4cf9ed3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/346f8a6912f4b5702b987cbb20f08fc87e6f5a46...0deea9fa0c1dd7c474827f64d17f0d19a4cf9ed3
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/20240821/7f0d83a5/attachment-0001.html>
More information about the ghc-commits
mailing list