[Git][ghc/ghc][wip/romes/25170-simpl] 2 commits: tweaks
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Jan 29 17:53:33 UTC 2025
Rodrigo Mesquita pushed to branch wip/romes/25170-simpl at Glasgow Haskell Compiler / GHC
Commits:
47c0da99 by Rodrigo Mesquita at 2025-01-29T10:48:58+00:00
tweaks
- - - - -
97108cc2 by Rodrigo Mesquita at 2025-01-29T17:53:22+00:00
More fixes
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Data/List/SetOps.hs
- compiler/GHC/Types/Id/Make.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2308,48 +2308,55 @@ 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_rewrite = TryRules _nr_wanted rules }) cont
+rebuildCall env original_info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+ , ai_rewrite = TryRules _nr_wanted rules }) original_cont
| [] <- rev_args
= -- Try rewrite rules on unsimplified arguments, then once more when all
-- arguments have been simplified (below). See Note [TODO]
- let (unsimp_info, res_cont') = take_unsimpl cont
- in applyRules (ai_args unsimp_info) res_cont'
+ let (unsimp_info, res_cont') = take_unsimpl_rev original_cont
+ in -- pprTrace "rebuildCall:1" (ppr original_info $$ ppr original_cont $$ ppr unsimp_info $$ ppr res_cont') $
+ applyRules False unsimp_info res_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]
- applyRules rev_args cont
+ applyRules True original_info original_cont
where
- applyRules rev_args' cont' = do
- mb_match <- tryRules env rules fun (reverse rev_args') cont'
+ applyRules are_simpl info' cont' = do
+ mb_match <- tryRules env rules are_simpl fun (reverse $ ai_args info') 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'') ->
+ pprTrace "Match:1" (text "aresimpl:" <+> ppr are_simpl
+ $$ ppr info' $$ text "rhs:" <+> ppr rhs $$ text "origcont:" <+> ppr cont' $$ text "newcont:" <+> ppr cont'') $
+ pprTrace "before try rules" (text "env:" <+> ppr (seInScope env) <+> ppr (seIdSubst env))
+ $ pprTrace "after try rules" (text "env':" <+> ppr (seInScope env') <+> ppr (seIdSubst env'))
+ $ simplExprF env' rhs cont''
+ Nothing -> rebuildCall env (original_info { ai_rewrite = TryInlining }) original_cont
-- 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
+ no_more_args = case original_cont of
ApplyToTy {} -> False
ApplyToVal {} -> False
_ -> True
+ take_unsimpl_rev k
+ | (i, k') <- take_unsimpl k
+ = (i{ ai_args = reverse (ai_args i) }, k')
take_unsimpl ApplyToVal { sc_arg = arg, sc_hole_ty = fun_ty, sc_cont = k }
| (i, k') <- take_unsimpl k
= (addValArgTo i arg fun_ty, k')
take_unsimpl ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = k }
| (i, k') <- take_unsimpl k
= (addTyArgTo i arg_ty hole_ty, k')
- take_unsimpl CastIt { sc_co = co, sc_opt = opt, sc_cont = k }
+ take_unsimpl CastIt { sc_co = co, sc_opt = _opt, sc_cont = k }
| (i, k') <- take_unsimpl k
- = (addCastTo i co', k')
- where -- must still simpl coercions
- co' = optOutCoercion env co opt
+ = (addCastTo i co, k')
take_unsimpl k
- = (info, k)
+ = (original_info, k)
---------- Simplify type applications and casts --------------
rebuildCall env info (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })
@@ -2465,7 +2472,7 @@ tryInlining env logger var cont
| not (logHasDumpFlag logger Opt_D_verbose_core2core)
= when (isExternalName (idName var)) $
log_inlining $
- sep [text "Inlining done:", nest 4 (ppr var)]
+ sep [text "Inlining done:", nest 4 (ppr var)] $$ sep [text "Inlining continuation:", nest 4 (ppr cont)]
| otherwise
= log_inlining $
sep [text "Inlining done: " <> ppr var,
@@ -2599,12 +2606,13 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity
-}
tryRules :: SimplEnv -> [CoreRule]
+ -> Bool -- Are the arguments already simplified?
-> Id
-> [ArgSpec] -- In /normal, forward/ order
-> SimplCont
-> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
-tryRules env rules fn args call_cont
+tryRules env rules are_simpl fn args call_cont
| null rules
= return Nothing
@@ -2613,10 +2621,11 @@ tryRules env rules fn args call_cont
(argInfoAppArgs args) rules
-- Fire a rule for the function
= do { logger <- getLogger
+ ; pprTraceM "tryRules" (text "rule:" <+> ppr rule $$ text "rhs:" <+> ppr rule_rhs $$ text "lookedup" <+> ppr fn <+> ppr (argInfoAppArgs args))
; checkedTick (RuleFired (ruleName rule))
- ; let cont' = pushSimplifiedArgs zapped_env
- (drop (ruleArity rule) args)
- call_cont
+ ; let cont' = pushArgs zapped_env
+ (drop (ruleArity rule) args)
+ call_cont
-- (ruleArity rule) says how
-- many args the rule consumed
@@ -2634,7 +2643,10 @@ tryRules env rules fn args call_cont
where
ropts = seRuleOpts env
- zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
+ zapped_env | are_simpl = zapSubstEnv env -- See Note [zapSubstEnv]
+ | otherwise = env -- (we only zap when the arguments are already simplified)
+ pushArgs | are_simpl = pushSimplifiedArgs
+ | otherwise = pushUnsimplifiedArgs
printRuleModule rule
= parens (maybe (text "BUILTIN")
@@ -2685,7 +2697,7 @@ trySeqRules :: SimplEnv
-- See Note [User-defined RULES for seq]
trySeqRules in_env scrut rhs cont
= do { rule_base <- getSimplRules
- ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }
+ ; tryRules in_env (getRules rule_base seqId) True seqId out_args rule_cont }
where
no_cast_scrut = drop_casts scrut
scrut_ty = exprType no_cast_scrut
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Core.Opt.Simplify.Utils (
ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo,
addValArgTo, addCastTo, addTyArgTo,
argInfoExpr, argInfoAppArgs,
- pushSimplifiedArgs, pushSimplifiedRevArgs,
+ pushSimplifiedArgs, pushSimplifiedRevArgs, pushUnsimplifiedArgs,
isStrictArgInfo, lazyArgContext,
abstractFloats,
@@ -405,12 +405,13 @@ 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
+pushSimplifiedArgs, pushSimplifiedRevArgs, pushUnsimplifiedArgs
:: SimplEnv
-> [ArgSpec] -- In normal, forward order for pushSimplifiedArgs,
-- in /reverse/ order for pushSimplifiedRevArgs
-> SimplCont -> SimplCont
pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args
+pushUnsimplifiedArgs env args cont = foldr (pushUnsimplifiedArg env) cont args
pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args
pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont
@@ -423,6 +424,15 @@ pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
pushSimplifiedArg _ (CastBy c) cont
= CastIt { sc_co = c, sc_cont = cont, sc_opt = True }
+pushUnsimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont
+pushUnsimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont
+ = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }
+pushUnsimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
+ = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = NoDup
+ , sc_hole_ty = hole_ty, sc_cont = cont }
+pushUnsimplifiedArg _ (CastBy c) cont
+ = CastIt { sc_co = c, sc_cont = cont, sc_opt = False }
+
argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
-- NB: the [ArgSpec] is reversed so that the first arg
-- in the list is the last one in the application
=====================================
compiler/GHC/Data/List/SetOps.hs
=====================================
@@ -40,7 +40,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord (comparing)
import qualified Data.Set as S
-getNth :: Outputable a => [a] -> Int -> a
+getNth :: (HasCallStack, Outputable a) => [a] -> Int -> a
getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $
xs !! n
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -566,7 +566,7 @@ mkDictSelRhs clas val_index
-- varToCoreExpr needed for equality superclass selectors
-- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
-dictSelRule :: Int -> Arity -> RuleFun
+dictSelRule :: HasCallStack => Int -> Arity -> RuleFun
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00ee0bc075441642724255007586d2720673aa61...97108cc2f21665aebea5101f930f8d902b573610
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00ee0bc075441642724255007586d2720673aa61...97108cc2f21665aebea5101f930f8d902b573610
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/20250129/4d114115/attachment-0001.html>
More information about the ghc-commits
mailing list