diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Driver.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 48 |
4 files changed, 39 insertions, 28 deletions
diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs index ae7e35c5c7..e7fed026d1 100644 --- a/compiler/GHC/Core/Opt/Driver.hs +++ b/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 } diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index b4d3766502..ffddd62c8c 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/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] diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 31b7541b50..173dcdf2c7 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/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 diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index f80f1951ed..acfa93efaa 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/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!)" |