[Git][ghc/ghc][master] DynFlags: avoid the use of sdocWithDynFlags in GHC.Core.Rules (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Fri Jul 3 21:34:06 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
41d26492 by Sylvain Henry at 2020-07-03T17:33:59-04:00
DynFlags: avoid the use of sdocWithDynFlags in GHC.Core.Rules (#17957)
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Driver.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Driver.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Driver.Types
import GHC.Core.Opt.CSE ( cseProgram )
import GHC.Core.Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
- getRules )
+ getRules, initRuleOpts )
import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import GHC.Types.Id.Info
@@ -497,9 +497,10 @@ ruleCheckPass current_phase pat guts =
; vis_orphs <- getVisibleOrphanMods
; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
++ (mg_rules guts)
+ ; let ropts = initRuleOpts dflags
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
$ withPprStyle defaultDumpStyle
- (ruleCheckProgram current_phase pat
+ (ruleCheckProgram ropts current_phase pat
rule_fn (mg_binds guts))
; return guts }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -50,7 +50,7 @@ import GHC.Core.Opt.Arity ( etaExpand )
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo )
-import GHC.Core.Rules ( lookupRule, getRules )
+import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts )
import GHC.Types.Basic
import GHC.Utils.Monad ( mapAccumLM, liftIO )
import GHC.Types.Var ( isTyCoVar )
@@ -2182,7 +2182,7 @@ tryRules env rules fn args call_cont
; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
-}
- | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)
+ | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)
(activeRule (getMode env)) fn
(argInfoAppArgs args) rules
-- Fire a rule for the function
@@ -2205,6 +2205,7 @@ tryRules env rules fn args call_cont
; return Nothing }
where
+ ropts = initRuleOpts dflags
dflags = seDynFlags env
zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1375,9 +1375,9 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
in_scope = Core.substInScope (se_subst env)
- already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
- already_covered dflags new_rules args -- Note [Specialisations already covered]
- = isJust (lookupRule dflags (in_scope, realIdUnfolding)
+ already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
+ already_covered ropts new_rules args -- Note [Specialisations already covered]
+ = isJust (lookupRule ropts (in_scope, realIdUnfolding)
(const True) fn args
(new_rules ++ existing_rules))
-- NB: we look both in the new_rules (generated by this invocation
@@ -1409,8 +1409,9 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- return ()
; dflags <- getDynFlags
+ ; let ropts = initRuleOpts dflags
; if not useful -- No useful specialisation
- || already_covered dflags rules_acc rule_lhs_args
+ || already_covered ropts rules_acc rule_lhs_args
then return spec_acc
else
do { -- Run the specialiser on the specialised RHS
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Core.Rules (
-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
- lookupRule, mkRule, roughTopNames
+ lookupRule, mkRule, roughTopNames, initRuleOpts
) where
#include "HsVersions.h"
@@ -375,14 +375,14 @@ pprRuleBase rules = pprUFM rules $ \rss ->
-- supplied rules to this instance of an application in a given
-- context, returning the rule applied and the resulting expression if
-- successful.
-lookupRule :: DynFlags -> InScopeEnv
+lookupRule :: RuleOpts -> InScopeEnv
-> (Activation -> Bool) -- When rule is active
-> Id -> [CoreExpr]
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-- See Note [Extra args in rule matching]
-- See comments on matchRule
-lookupRule dflags in_scope is_active fn args rules
+lookupRule opts in_scope is_active fn args rules
= -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
case go [] rules of
[] -> Nothing
@@ -399,7 +399,7 @@ lookupRule dflags in_scope is_active fn args rules
go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
go ms [] = ms
go ms (r:rs)
- | Just e <- matchRule dflags in_scope is_active fn args' rough_args r
+ | Just e <- matchRule opts in_scope is_active fn args' rough_args r
= go ((r,mkTicks ticks e):ms) rs
| otherwise
= -- pprTrace "match failed" (ppr r $$ ppr args $$
@@ -478,7 +478,7 @@ to lookupRule are the result of a lazy substitution
-}
------------------------------------
-matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
+matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
-> Id -> [CoreExpr] -> [Maybe Name]
-> CoreRule -> Maybe CoreExpr
@@ -504,15 +504,10 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
-matchRule dflags rule_env _is_active fn args _rough_args
+matchRule opts rule_env _is_active fn args _rough_args
(BuiltinRule { ru_try = match_fn })
-- Built-in rules can't be switched off, it seems
- = let env = RuleOpts
- { roPlatform = targetPlatform dflags
- , roNumConstantFolding = gopt Opt_NumConstantFolding dflags
- , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
- }
- in case match_fn env rule_env fn args of
+ = case match_fn opts rule_env fn args of
Nothing -> Nothing
Just expr -> Just expr
@@ -523,6 +518,16 @@ matchRule _ in_scope is_active _ args rough_args
| ruleCantMatch tpl_tops rough_args = Nothing
| otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs
+
+-- | Initialize RuleOpts from DynFlags
+initRuleOpts :: DynFlags -> RuleOpts
+initRuleOpts dflags = RuleOpts
+ { roPlatform = targetPlatform dflags
+ , roNumConstantFolding = gopt Opt_NumConstantFolding dflags
+ , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
+ }
+
+
---------------------------------------
matchN :: InScopeEnv
-> RuleName -> [Var] -> [CoreExpr]
@@ -1155,12 +1160,13 @@ is so important.
-- | Report partial matches for rules beginning with the specified
-- string for the purposes of error reporting
-ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
+ruleCheckProgram :: RuleOpts -- ^ Rule options
+ -> CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern
-> (Id -> [CoreRule]) -- ^ Rules for an Id
-> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
-ruleCheckProgram phase rule_pat rules binds
+ruleCheckProgram ropts phase rule_pat rules binds
| isEmptyBag results
= text "Rule check results: no rule application sites"
| otherwise
@@ -1173,7 +1179,9 @@ ruleCheckProgram phase rule_pat rules binds
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
- , rc_rules = rules }
+ , rc_rules = rules
+ , rc_ropts = ropts
+ }
results = unionManyBags (map (ruleCheckBind env) binds)
line = text (replicate 20 '-')
@@ -1181,7 +1189,8 @@ data RuleCheckEnv = RuleCheckEnv {
rc_is_active :: Activation -> Bool,
rc_id_unf :: IdUnfoldingFun,
rc_pattern :: String,
- rc_rules :: Id -> [CoreRule]
+ rc_rules :: Id -> [CoreRule],
+ rc_ropts :: RuleOpts
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
@@ -1228,16 +1237,15 @@ ruleAppCheck_help env fn args rules
i_args = args `zip` [1::Int ..]
rough_args = map roughTopName args
- check_rule rule = sdocWithDynFlags $ \dflags ->
- rule_herald rule <> colon <+> rule_info dflags rule
+ check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule
rule_herald (BuiltinRule { ru_name = name })
= text "Builtin rule" <+> doubleQuotes (ftext name)
rule_herald (Rule { ru_name = name })
= text "Rule" <+> doubleQuotes (ftext name)
- rule_info dflags rule
- | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env)
+ rule_info opts rule
+ | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)
noBlackList fn args rough_args rule
= text "matches (which is very peculiar!)"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41d2649288a5debcb4c8003e54b7d3072ab951c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41d2649288a5debcb4c8003e54b7d3072ab951c5
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/20200703/60bc18b4/attachment-0001.html>
More information about the ghc-commits
mailing list