diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-02-17 18:41:58 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-22 18:27:12 -0500 |
commit | 3aceea907fb7fc4299397e6333e093befcf76cb0 (patch) | |
tree | 47a0c145bf1a9869a60df274cc6aebfd4278c7dd | |
parent | 847b0a6950ffdead534d0d4982f50ad17ae7cce0 (diff) | |
download | haskell-3aceea907fb7fc4299397e6333e093befcf76cb0.tar.gz |
Don't pass homeUnitId at ExternalPackageState creation time (#10827)
It makes the external package state independent of the home unit which
is needed to make several home units share the EPS.
-rw-r--r-- | compiler/GHC/Core.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/Core/Rules.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Load.hs | 16 |
5 files changed, 23 insertions, 25 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 230d3498ce..168e33e189 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -1400,6 +1400,7 @@ 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 } type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index dfb24b6cc4..02a3983e92 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -35,7 +35,6 @@ module GHC.Core.Opt.ConstantFold ( primOpRules , builtinRules , caseRules - , EnableBignumRules (..) ) where @@ -1676,11 +1675,9 @@ bindings (see occurAnalysePgm), which sorts out the dependency, so all is fine. -} -newtype EnableBignumRules = EnableBignumRules Bool - -builtinRules :: EnableBignumRules -> [CoreRule] +builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma -builtinRules enableBignumRules +builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, ru_nargs = 4, ru_try = match_append_lit_C }, @@ -1719,14 +1716,13 @@ builtinRules enableBignumRules `App` arg `App` mkIntVal platform (d - 1) ] ] - ++ builtinBignumRules enableBignumRules + ++ builtinBignumRules {-# NOINLINE builtinRules #-} -- there is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. -builtinBignumRules :: EnableBignumRules -> [CoreRule] -builtinBignumRules (EnableBignumRules False) = [] -builtinBignumRules _ = +builtinBignumRules :: [CoreRule] +builtinBignumRules = [ -- conversions lit_to_integer "Word# -> Integer" integerFromWordName , lit_to_integer "Int64# -> Integer" integerFromInt64Name @@ -1872,7 +1868,10 @@ builtinBignumRules _ = { ru_name = fsLit str , ru_fn = name , ru_nargs = nargs - , ru_try = runRuleM f + , ru_try = runRuleM $ do + env <- getEnv + guard (roBignumRules env) + f } integer_to_lit str name convert = mkRule str name 1 $ do diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 5d5330d510..f29d700719 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -31,6 +31,7 @@ module GHC.Core.Rules ( import GHC.Prelude import GHC.Core -- All of it +import GHC.Unit.Types ( primUnitId, bignumUnitId ) import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env import GHC.Core.Subst @@ -59,7 +60,7 @@ import GHC.Types.Name.Env import GHC.Types.Unique.FM import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) import GHC.Driver.Ppr import GHC.Driver.Flags import GHC.Utils.Outputable @@ -524,9 +525,12 @@ matchRule _ in_scope is_active _ args rough_args -- | Initialize RuleOpts from DynFlags initRuleOpts :: DynFlags -> RuleOpts initRuleOpts dflags = RuleOpts - { roPlatform = targetPlatform dflags - , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + { 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/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 6c80c6827c..f16685775b 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -239,7 +239,7 @@ newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do -- we don't store the unit databases and the unit state to still -- allow `setSessionDynFlags` to be used to set unit db flags. - eps_var <- newIORef (initExternalPackageState (homeUnitId_ dflags)) + eps_var <- newIORef initExternalPackageState us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index e8f1c62592..b1a4f4d27c 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -78,7 +78,7 @@ import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) +import GHC.Types.Id.Make ( seqId ) import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Env @@ -962,8 +962,8 @@ readIface wanted_mod file_path ********************************************************* -} -initExternalPackageState :: UnitId -> ExternalPackageState -initExternalPackageState home_unit_id +initExternalPackageState :: ExternalPackageState +initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, @@ -971,21 +971,15 @@ initExternalPackageState home_unit_id eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, - eps_rule_base = mkRuleBase builtinRules', + eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules eps_mod_fam_inst_env = emptyModuleEnv, eps_complete_matches = [], eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 - , n_rules_in = length builtinRules', n_rules_out = 0 } + , n_rules_in = length builtinRules, n_rules_out = 0 } } - where - enableBignumRules - | home_unit_id == primUnitId = EnableBignumRules False - | home_unit_id == bignumUnitId = EnableBignumRules False - | otherwise = EnableBignumRules True - builtinRules' = builtinRules enableBignumRules {- ********************************************************* |