diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2022-08-04 21:27:57 +0200 |
---|---|---|
committer | Andreas Klebinger <klebinger.andreas@gmx.at> | 2022-08-04 21:27:57 +0200 |
commit | 8a1e34813449b2b0fcab2857c2820b5e20fa734e (patch) | |
tree | 1a0c83f8ee1cc1c5287522154d4a79df9c9bf483 | |
parent | b99819bdaa11881f0b0bec29ef6274a8c8e565a0 (diff) | |
download | haskell-wip/andreask/keep-auto-rules.tar.gz |
Add a flag to optionally keep auto-generated rules around.wip/andreask/keep-auto-rules
-rw-r--r-- | compiler/GHC/Driver/Config/Tidy.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 12 |
4 files changed, 12 insertions, 3 deletions
diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs index 89bdf31b2c..9a73abff00 100644 --- a/compiler/GHC/Driver/Config/Tidy.hs +++ b/compiler/GHC/Driver/Config/Tidy.hs @@ -43,6 +43,7 @@ initTidyOpts hsc_env = do , opt_expose_rules = not (gopt Opt_OmitInterfacePragmas dflags) , opt_trim_ids = gopt Opt_OmitInterfacePragmas dflags , opt_static_ptr_opts = static_ptr_opts + , opt_keep_orphan_rules = gopt Opt_KeepAutoRules dflags } initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index a4e5827bc6..bb626fccfc 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -297,6 +297,7 @@ data GeneralFlag | Opt_IgnoreInterfacePragmas | Opt_OmitInterfacePragmas | Opt_ExposeAllUnfoldings + | Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless | Opt_WriteInterface -- forces .hi files to be written even with -fno-code | Opt_WriteHie -- generate .hie files diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 43f58884fc..223d7789d0 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3388,6 +3388,7 @@ fFlagsDeps = [ flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "keep-auto-rules" Opt_KeepAutoRules, flagSpec "expose-internal-symbols" Opt_ExposeInternalSymbols, flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, flagSpec "external-interpreter" Opt_ExternalInterpreter, diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index f395c0daa8..f53d81ba81 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -358,6 +358,7 @@ data TidyOpts = TidyOpts -- ^ Are rules exposed or not? , opt_static_ptr_opts :: !(Maybe StaticPtrOpts) -- ^ Options for generated static pointers, if enabled (/= Nothing). + , opt_keep_orphan_rules :: !Bool } tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails) @@ -382,6 +383,7 @@ tidyProgram opts (ModGuts { mg_module = mod let implicit_binds = concatMap getImplicitBinds tcs (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules + -- pprTraceM "findExternalRules" $ ppr imp_rules let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env let uf_opts = opt_unfolding_opts opts @@ -392,6 +394,8 @@ tidyProgram opts (ModGuts { mg_module = mod Nothing -> pure ([], Nothing, tidy_binds) Just sopts -> sptCreateStaticBinds sopts mod tidy_binds + -- pprTraceM "trimmed_rules" (ppr trimmed_rules) + let all_foreign_stubs = case mcstub of Nothing -> foreign_stubs Just cstub -> foreign_stubs `appendStubC` cstub @@ -976,10 +980,13 @@ findExternalRules :: TidyOpts findExternalRules opts binds imp_id_rules unfold_env = (trimmed_binds, filter keep_rule all_rules) where - imp_rules = filter expose_rule imp_id_rules + imp_rules + | not (opt_expose_rules opts) = [] + | otherwise = filter expose_rule imp_id_rules imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules - user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet + user_rule_rhs_fvs rule | isAutoRule rule && not (opt_keep_orphan_rules opts) + = emptyVarSet | otherwise = ruleRhsFreeVars rule (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds @@ -998,7 +1005,6 @@ findExternalRules opts binds imp_id_rules unfold_env -- been discarded; see Note [Trimming auto-rules] expose_rule rule - | not (opt_expose_rules opts) = False | otherwise = all is_external_id (ruleLhsFreeIdsList rule) -- Don't expose a rule whose LHS mentions a locally-defined -- Id that is completely internal (i.e. not visible to an |