diff options
| -rw-r--r-- | compiler/GHC/Core.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/CallerCC.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/CprAnal.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/FloatOut.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs-boot | 30 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 87 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules/Config.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/Core/Rules.hs | 23 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
| -rw-r--r-- | testsuite/tests/count-deps/CountDepsAst.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/count-deps/CountDepsParser.stdout | 3 |
17 files changed, 127 insertions, 110 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 36fa6e2673..c3f861e2f9 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -85,7 +85,7 @@ module GHC.Core ( -- * Core rule data types CoreRule(..), RuleBase, RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv, + RuleEnv(..), RuleOpts, mkRuleEnv, emptyRuleEnv, -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, @@ -100,6 +100,7 @@ import GHC.Types.Var.Env( InScopeSet ) import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.Rules.Config ( RuleOpts ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env( NameEnv ) @@ -1201,14 +1202,6 @@ data CoreRule } -- See Note [Extra args in the target] in GHC.Core.Rules --- | Rule options -data RuleOpts = RuleOpts - { roPlatform :: !Platform -- ^ Target platform - , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding - , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled - , roBignumRules :: !Bool -- ^ Enable rules for bignums - } - -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are -- currently in scope. See Note [The InScopeSet invariant]. type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index e8ac5a7cff..ba9f809092 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -27,7 +27,6 @@ import qualified Text.ParserCombinators.ReadP as P import GHC.Prelude import GHC.Utils.Outputable as Outputable import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) @@ -52,7 +51,7 @@ addCallerCostCentres guts = do env = Env { thisModule = mg_module guts , ccState = newCostCentreState - , dflags = dflags + , countEntries = gopt Opt_ProfCountEntries dflags , revParents = [] , filters = filters } @@ -78,9 +77,9 @@ doExpr env e@(Var v) hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v) ccName :: CcName - ccName = mkFastString $ showSDoc (dflags env) nameDoc + ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc ccIdx <- getCCIndex' ccName - let count = gopt Opt_ProfCountEntries (dflags env) + let count = countEntries env span = case revParents env of top:_ -> nameSrcSpan $ varName top _ -> noSrcSpan @@ -109,7 +108,7 @@ getCCIndex' name = state (getCCIndex name) data Env = Env { thisModule :: Module - , dflags :: DynFlags + , countEntries :: !Bool , ccState :: CostCentreState , revParents :: [Id] , filters :: [CallerCcFilter] diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 1904344788..c2fc84687e 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -49,6 +49,7 @@ import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, data import GHC.Core.Utils ( cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity +import GHC.Core.Rules.Config import GHC.Core.Type import GHC.Core.TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon @@ -1835,12 +1836,12 @@ dataToTagRule = a `mplus` b -- dataToTag x -- where x's unfolding is a constructor application b = do - dflags <- getPlatform + platform <- getPlatform [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg massert (not (isNewTyCon (dataConTyCon dc))) - return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) {- Note [dataToTag# magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 3f6455c9cf..f6120d64b8 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -10,7 +10,7 @@ module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Builtin.Names ( runRWKey ) diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 19b687a4a3..362cab0056 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -18,7 +18,7 @@ import GHC.Core.Make import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) -import GHC.Driver.Session +import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Utils.Logger import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index ef9f851e61..4182be9fb9 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -27,7 +27,8 @@ module GHC.Core.Opt.Monad ( CoreM, runCoreM, -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, + getHscEnv, getModule, + getRuleBase, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, getVisibleOrphanMods, getUniqMask, getPrintUnqualified, getSrcSpanM, @@ -707,6 +708,9 @@ getHscEnv = read cr_hsc_env getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base +getExternalRuleBase :: CoreM RuleBase +getExternalRuleBase = eps_rule_base <$> get_eps + getVisibleOrphanMods :: CoreM ModuleSet getVisibleOrphanMods = read cr_visible_orphan_mods @@ -734,10 +738,12 @@ instance HasModule CoreM where getModule = read cr_module getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do +getPackageFamInstEnv = eps_fam_inst_env <$> get_eps + +get_eps :: CoreM ExternalPackageState +get_eps = do hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps + liftIO $ hscEPS hsc_env {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Monad.hs-boot b/compiler/GHC/Core/Opt/Monad.hs-boot deleted file mode 100644 index b92602dc59..0000000000 --- a/compiler/GHC/Core/Opt/Monad.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- Created this hs-boot file to remove circular dependencies from the use of --- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core --- transformations. --- However GHC.Core.Opt.Monad does much more than defining these, and because Plugins are --- activated in various modules, the imports become circular. To solve this I --- extracted CoreToDo and CoreM into this file. --- I needed to write the whole definition of these types, otherwise it created --- a data-newtype conflict. - -module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where - -import GHC.Prelude - -import GHC.Data.IOEnv ( IOEnv ) - -type CoreIOEnv = IOEnv CoreReader - -data CoreReader - -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -data SimplCount - -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - -instance Monad CoreM - -data CoreToDo diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 1e336532eb..93e113cd89 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -15,13 +15,14 @@ import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( mkRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo, - getRules, initRuleOpts ) + getRules ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index f87a28f440..f052bae942 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -43,9 +43,11 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) +import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Core.Multiplicity +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) + import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 import GHC.Types.SourceText import GHC.Types.Id diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index c07b8ae954..8b303f0316 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -799,7 +799,7 @@ specConstrProgram guts this_mod <- getModule let binds' = reverse $ fst $ initUs us $ do -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) + (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos) (mg_binds guts) -- binds is identical to (mg_binds guts), except that the -- binders on the LHS have been replaced by extendBndr @@ -904,24 +904,38 @@ scrutinised in the body. True <=> ignore that, and specialise whenever the function is applied to a data constructor. -} -data ScEnv = SCE { sc_dflags :: DynFlags, - sc_uf_opts :: !UnfoldingOpts, -- ^ Unfolding options - sc_module :: !Module, - sc_size :: Maybe Int, -- Size threshold - -- Nothing => no limit +-- | Options for Specializing over constructors in Core. +data SpecConstrOpts = SpecConstrOpts + { sc_max_args :: !Int + -- ^ The threshold at which a worker-wrapper transformation used as part of + -- this pass will no longer happen, measured in the number of arguments. - sc_count :: Maybe Int, -- Max # of specialisations for any one fn - -- Nothing => no limit - -- See Note [Avoiding exponential blowup] + , sc_debug :: !Bool + -- ^ Whether to print debug information - sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. + , sc_uf_opts :: !UnfoldingOpts + -- ^ Unfolding options - sc_keen :: Bool, -- Specialise on arguments that are known - -- constructors, even if they are not - -- scrutinised in the body. See - -- Note [Making SpecConstr keener] + , sc_module :: !Module + -- ^ The name of the module being processed + , sc_size :: !(Maybe Int) + -- ^ Size threshold: Nothing => no limit + + , sc_count :: !(Maybe Int) + -- ^ Max # of specialisations for any one function. Nothing => no limit. + -- See Note [Avoiding exponential blowup]. + + , sc_recursive :: !Int + -- ^ Max # of specialisations over recursive type. Stops + -- ForceSpecConstr from diverging. + + , sc_keen :: !Bool + -- ^ Specialise on arguments that are known constructors, even if they are + -- not scrutinised in the body. See Note [Making SpecConstr keener]. + } + +data ScEnv = SCE { sc_opts :: !SpecConstrOpts, sc_force :: Bool, -- Force specialisation? -- See Note [Forcing specialisation] @@ -957,15 +971,21 @@ instance Outputable Value where ppr LambdaVal = text "<Lambda>" --------------------- -initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns - = SCE { sc_dflags = dflags, +initScOpts :: DynFlags -> Module -> SpecConstrOpts +initScOpts dflags this_mod = SpecConstrOpts + { sc_max_args = maxWorkerArgs dflags, + sc_debug = hasPprDebug dflags, sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod, sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, sc_recursive = specConstrRecursive dflags, - sc_keen = gopt Opt_SpecConstrKeen dflags, + sc_keen = gopt Opt_SpecConstrKeen dflags + } + +initScEnv :: SpecConstrOpts -> UniqFM Name SpecConstrAnnotation -> ScEnv +initScEnv opts anns + = SCE { sc_opts = opts, sc_force = False, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, @@ -1091,9 +1111,12 @@ decreaseSpecCount :: ScEnv -> Int -> ScEnv -- See Note [Avoiding exponential blowup] decreaseSpecCount env n_specs = env { sc_force = False -- See Note [Forcing specialisation] - , sc_count = case sc_count env of + , sc_opts = (sc_opts env) + { sc_count = case sc_count $ sc_opts env of Nothing -> Nothing - Just n -> Just (n `div` (n_specs + 1)) } + Just n -> Just $! (n `div` (n_specs + 1)) + } + } -- The "+1" takes account of the original function; -- See Note [Avoiding exponential blowup] @@ -1506,9 +1529,9 @@ scTopBindEnv env (NonRec bndr rhs) scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) scTopBind env body_usage (Rec prs) - | Just threshold <- sc_size env + | Just threshold <- sc_size $ sc_opts env , not force_spec - , not (all (couldBeSmallEnoughToInline (sc_uf_opts env) threshold) rhss) + , not (all (couldBeSmallEnoughToInline (sc_uf_opts $ sc_opts env) threshold) rhss) -- No specialisation = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss @@ -1623,6 +1646,7 @@ specRec :: TopLevelFlag -> ScEnv specRec top_lvl env body_usg rhs_infos = go 1 seed_calls nullUsage init_spec_infos where + opts = sc_opts env (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] | isTopLevel top_lvl , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs @@ -1652,8 +1676,8 @@ specRec top_lvl env body_usg rhs_infos -- Limit recursive specialisation -- See Note [Limit recursive specialisation] - | n_iter > sc_recursive env -- Too many iterations of the 'go' loop - , sc_force env || isNothing (sc_count env) + | n_iter > sc_recursive opts -- Too many iterations of the 'go' loop + , sc_force env || isNothing (sc_count opts) -- If both of these are false, the sc_count -- threshold will prevent non-termination , any ((> the_limit) . si_n_specs) spec_infos @@ -1672,7 +1696,7 @@ specRec top_lvl env body_usg rhs_infos ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } -- See Note [Limit recursive specialisation] - the_limit = case sc_count env of + the_limit = case sc_count opts of Nothing -> 10 -- Ugh! Just max -> max @@ -1860,7 +1884,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args` dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn - this_mod = sc_module env + this_mod = sc_module $ sc_opts env rule = mkRule this_mod True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation] @@ -2205,9 +2229,8 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups - max_args = maxWorkerArgs (sc_dflags env) too_big (CP { cp_qvars = vars, cp_args = args }) - = not (isWorkerSmallEnough max_args (valArgCount args) vars) + = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars) -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils @@ -2244,7 +2267,7 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats n_pats = length pats spec_count' = n_pats + done_spec_count n_remaining = max_specs - done_spec_count - mb_scc = sc_count env + mb_scc = sc_count $ sc_opts env Just max_specs = mb_scc sorted_pats = map fst $ @@ -2269,7 +2292,7 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats n_cons _ = 0 emit_trace result - | debugIsOn || hasPprDebug (sc_dflags env) + | debugIsOn || sc_debug (sc_opts env) -- Suppress this scary message for ordinary users! #5125 = pprTrace "SpecConstr" msg result | otherwise @@ -2480,7 +2503,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc -> Just (occs) -- See Note [Reboxing] - _other | sc_force env || sc_keen env + _other | sc_force env || sc_keen (sc_opts env) -> Just (repeat UnkOcc) | otherwise -> Nothing diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 1e429a4c1e..74ee8d1f5f 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -16,7 +16,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Driver.Config.Diagnostic -import GHC.Driver.Env +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Tc.Utils.TcType hiding( substTy ) @@ -65,7 +65,6 @@ import GHC.Utils.Trace import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts -import GHC.Unit.External import GHC.Core.Unfold {- @@ -736,10 +735,9 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _) = do { -- Get rules from the external package state -- We keep doing this in case we "page-fault in" -- more rules as we go along - ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env + ; external_rule_base <- getExternalRuleBase ; vis_orphs <- getVisibleOrphanMods - ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn + ; let rules_for_fn = getRules (RuleEnv [rb, external_rule_base] vis_orphs) fn ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index a8c9cbef5a..451d1ac5c1 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -22,15 +22,11 @@ module GHC.Core.Rules ( -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames, initRuleOpts + lookupRule, mkRule, roughTopNames ) where import GHC.Prelude -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) -import GHC.Driver.Flags - -import GHC.Unit.Types ( primUnitId, bignumUnitId ) import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env @@ -546,18 +542,6 @@ matchRule _ rule_env is_active _ args rough_args | otherwise = matchN rule_env 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 - -- disable bignum rules in ghc-prim and ghc-bignum itself - , roBignumRules = homeUnitId_ dflags /= primUnitId - && homeUnitId_ dflags /= bignumUnitId - } - - --------------------------------------- matchN :: InScopeEnv -> RuleName -> [Var] -> [CoreExpr] diff --git a/compiler/GHC/Core/Rules/Config.hs b/compiler/GHC/Core/Rules/Config.hs new file mode 100644 index 0000000000..2ae1e35a67 --- /dev/null +++ b/compiler/GHC/Core/Rules/Config.hs @@ -0,0 +1,13 @@ +module GHC.Core.Rules.Config where + +import GHC.Prelude +import GHC.Platform + +-- | Rule options +data RuleOpts = RuleOpts + { roPlatform :: !Platform -- ^ Target platform + , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding + , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled + , roBignumRules :: !Bool -- ^ Enable rules for bignums + } + diff --git a/compiler/GHC/Driver/Config/Core/Rules.hs b/compiler/GHC/Driver/Config/Core/Rules.hs new file mode 100644 index 0000000000..6663e4be8a --- /dev/null +++ b/compiler/GHC/Driver/Config/Core/Rules.hs @@ -0,0 +1,23 @@ +module GHC.Driver.Config.Core.Rules + ( initRuleOpts + ) where + +import GHC.Prelude + +import GHC.Driver.Flags +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) + +import GHC.Core.Rules.Config + +import GHC.Unit.Types ( primUnitId, bignumUnitId ) + +-- | Initialize RuleOpts from DynFlags +initRuleOpts :: DynFlags -> RuleOpts +initRuleOpts dflags = RuleOpts + { roPlatform = targetPlatform dflags + , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags + -- disable bignum rules in ghc-prim and ghc-bignum itself + , roBignumRules = homeUnitId_ dflags /= primUnitId + && homeUnitId_ dflags /= bignumUnitId + } diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 74d95cdc65..d757925444 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -335,6 +335,7 @@ Library GHC.Core.Predicate GHC.Core.Reduction GHC.Core.Rules + GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats @@ -399,6 +400,7 @@ Library GHC.Driver.Config.Core.Opt.Arity GHC.Driver.Config.Core.Opt.LiberateCase GHC.Driver.Config.Core.Opt.WorkWrap + GHC.Driver.Config.Core.Rules GHC.Driver.Config.Diagnostic GHC.Driver.Config.Finder GHC.Driver.Config.HsToCore diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 31cf9d458a..1cacba20b2 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 285 Language.Haskell.Syntax module dependencies +Found 286 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -46,6 +46,7 @@ GHC.Core.Predicate GHC.Core.Reduction GHC.Core.RoughMap GHC.Core.Rules +GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index b3834a0f92..d6690e7306 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 292 GHC.Parser module dependencies +Found 293 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -46,6 +46,7 @@ GHC.Core.Predicate GHC.Core.Reduction GHC.Core.RoughMap GHC.Core.Rules +GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats |