Modularize Tidy (#17957)

- Factorize Tidy options into TidyOpts datatype. Initialize it in
  GHC.Driver.Config.Tidy
- Same thing for StaticPtrOpts
- Perform lookups of unpackCString[Utf8]# once in initStaticPtrOpts
  instead of for every use of mkStringExprWithFS

7 files changed, 328 insertions, 250 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index c62f4baa3b..b573f2769e 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -338,7 +338,6 @@ import GHC.Parser.Utils
 import GHC.Iface.Load        ( loadSysInterface )
 import GHC.Hs
 import GHC.Builtin.Types.Prim ( alphaTyVars )
-import GHC.Iface.Tidy
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
 import qualified GHC.LanguageExtensions as LangExt
@@ -1330,12 +1329,12 @@ compileCore simplify fn = do
          if simplify
           then do
              -- If simplify is true: simplify (hscSimplify), then tidy
-             -- (tidyProgram).
+             -- (hscTidy).
              hsc_env <- getSession
              simpl_guts <- liftIO $ do
                plugins <- readIORef (tcg_th_coreplugins tcg)
                hscSimplify hsc_env plugins mod_guts
-             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
+             tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts
              return $ Left tidy_guts
           else
              return $ Right mod_guts
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 200847134b..932bf8aa8d 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -19,6 +19,7 @@ module GHC.Core.Make (
         mkIntegerExpr, mkNaturalExpr,
         mkFloatExpr, mkDoubleExpr,
         mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
+        MkStringIds (..), getMkStringIds,
 
         -- * Floats
         FloatBind(..), wrapFloat, wrapFloats, floatBindings,
@@ -333,26 +334,37 @@ mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]
 
 -- | Create a 'CoreExpr' which will evaluate to the given @String@
 mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String
+mkStringExpr str = mkStringExprFS (mkFastString str)
 
 -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
 mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String
+mkStringExprFS = mkStringExprFSLookup lookupId
 
-mkStringExpr str = mkStringExprFS (mkFastString str)
+mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
+mkStringExprFSLookup lookupM str = do
+  mk <- getMkStringIds lookupM
+  pure (mkStringExprFSWith mk str)
+
+getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds
+getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name
 
-mkStringExprFS = mkStringExprFSWith lookupId
+data MkStringIds = MkStringIds
+  { unpackCStringId     :: !Id
+  , unpackCStringUtf8Id :: !Id
+  }
 
-mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
-mkStringExprFSWith lookupM str
+mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr
+mkStringExprFSWith ids str
   | nullFS str
-  = return (mkNilExpr charTy)
+  = mkNilExpr charTy
 
   | all safeChar chars
-  = do unpack_id <- lookupM unpackCStringName
-       return (App (Var unpack_id) lit)
+  = let !unpack_id = unpackCStringId ids
+    in App (Var unpack_id) lit
 
   | otherwise
-  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
-       return (App (Var unpack_utf8_id) lit)
+  = let !unpack_utf8_id = unpackCStringUtf8Id ids
+    in App (Var unpack_utf8_id) lit
 
   where
     chars = unpackFS str
diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs
new file mode 100644
index 0000000000..d7ad76fc87
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Tidy.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
+
+module GHC.Driver.Config.Tidy
+  ( initTidyOpts
+  , initStaticPtrOpts
+  )
+where
+
+import GHC.Prelude
+
+import GHC.Iface.Tidy
+import GHC.Iface.Tidy.StaticPtrTable
+
+import GHC.Driver.Session
+import GHC.Driver.Env
+import GHC.Driver.Backend
+
+import GHC.Core.Make (getMkStringIds)
+import GHC.Data.Maybe
+import GHC.Utils.Panic
+import GHC.Utils.Outputable
+import GHC.Builtin.Names
+import GHC.Tc.Utils.Env (lookupGlobal_maybe)
+import GHC.Types.TyThing
+import GHC.Platform.Ways
+
+import qualified GHC.LanguageExtensions as LangExt
+
+initTidyOpts :: HscEnv -> IO TidyOpts
+initTidyOpts hsc_env = do
+  let dflags = hsc_dflags hsc_env
+  static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags)
+    then pure Nothing
+    else Just <$> initStaticPtrOpts hsc_env
+  pure $ TidyOpts
+    { opt_name_cache        = hsc_NC hsc_env
+    , opt_collect_ccs       = ways dflags `hasWay` WayProf
+    , opt_unfolding_opts    = unfoldingOpts dflags
+    , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone
+                                 | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll
+                                 | otherwise                            -> ExposeSome
+    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)
+    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags
+    , opt_static_ptr_opts   = static_ptr_opts
+    }
+
+initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
+initStaticPtrOpts hsc_env = do
+  let dflags = hsc_dflags hsc_env
+
+  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case
+        Succeeded r -> pure r
+        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))
+
+  mk_string <- getMkStringIds (fmap tyThingId . lookupM)
+  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName
+  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName
+
+  pure $ StaticPtrOpts
+    { opt_platform = targetPlatform dflags
+
+      -- If we are compiling for the interpreter we will insert any necessary
+      -- SPT entries dynamically, otherwise we add a C stub to do so
+    , opt_gen_cstub = case backend dflags of
+                        Interpreter -> False
+                        _           -> True
+
+    , opt_mk_string = mk_string
+    , opt_static_ptr_info_datacon = static_ptr_info_datacon
+    , opt_static_ptr_datacon      = static_ptr_datacon
+    }
+
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 62187d573f..32b94fbf14 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -79,6 +79,9 @@ module GHC.Driver.Main
     , hscParseExpr
     , hscParseType
     , hscCompileCoreExpr
+    , hscTidy
+
+
     -- * Low-level exports for hooks
     , hscCompileCoreExpr'
       -- We want to make sure that we export enough to be able to redefine
@@ -109,6 +112,7 @@ import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
 import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
 import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
 import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Config.Tidy
 import GHC.Driver.Hooks
 
 import GHC.Runtime.Context
@@ -142,14 +146,17 @@ import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )
 import GHC.Core
 import GHC.Core.Tidy           ( tidyExpr )
 import GHC.Core.Type           ( Type, Kind )
-import GHC.Core.Lint           ( lintInteractiveExpr )
+import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )
 import GHC.Core.Multiplicity
 import GHC.Core.Utils          ( exprType )
 import GHC.Core.ConLike
+import GHC.Core.Opt.Monad      ( CoreToDo (..))
 import GHC.Core.Opt.Pipeline
 import GHC.Core.TyCon
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
+import GHC.Core.Rules
+import GHC.Core.Stats
 
 import GHC.CoreToStg.Prep
 import GHC.CoreToStg    ( coreToStg )
@@ -940,8 +947,8 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
           plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
           simplified_guts <- hscSimplify' plugins desugared_guts
 
-          (cg_guts, details) <- {-# SCC "CoreTidy" #-}
-              liftIO $ tidyProgram hsc_env simplified_guts
+          (cg_guts, details) <-
+              liftIO $ hscTidy hsc_env simplified_guts
 
           let !partial_iface =
                 {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
@@ -2027,7 +2034,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
       hscSimplify hsc_env plugins ds_result
 
     {- Tidy -}
-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
+    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg
 
     let !CgGuts{ cg_module    = this_mod,
                  cg_binds     = core_binds,
@@ -2197,6 +2204,44 @@ hscParseThingWithLocation source linenumber parser str = do
                             FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)
                 return thing
 
+hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
+hscTidy hsc_env guts = do
+  let logger   = hsc_logger hsc_env
+  let this_mod = mg_module guts
+
+  opts <- initTidyOpts hsc_env
+  (cgguts, details) <- withTiming logger
+    (text "CoreTidy"<+>brackets (ppr this_mod))
+    (const ())
+    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
+
+  -- post tidy pretty-printing and linting...
+  let tidy_rules     = md_rules details
+  let all_tidy_binds = cg_binds cgguts
+  let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)
+
+  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
+
+  -- If the endPass didn't print the rules, but ddump-rules is
+  -- on, print now
+  unless (logHasDumpFlag logger Opt_D_dump_simpl) $
+    putDumpFileMaybe logger Opt_D_dump_rules
+      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))
+      FormatText
+      (pprRulesForUser tidy_rules)
+
+  -- Print one-line size info
+  let cs = coreBindsStats all_tidy_binds
+  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
+    FormatText
+    (text "Tidy size (terms,types,coercions)"
+     <+> ppr (moduleName this_mod) <> colon
+     <+> int (cs_tm cs)
+     <+> int (cs_ty cs)
+     <+> int (cs_co cs))
+
+  pure (cgguts, details)
+
 
 {- **********************************************************************
 %*                                                                      *
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 268c43945e..85cd431c37 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -6,21 +6,19 @@
 
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section{Tidying up Core}
 -}
 
-module GHC.Iface.Tidy (
-       mkBootModDetailsTc, tidyProgram
-   ) where
+-- | Tidying up Core
+module GHC.Iface.Tidy
+  ( TidyOpts (..)
+  , UnfoldingExposure (..)
+  , tidyProgram
+  , mkBootModDetailsTc
+  )
+where
 
 import GHC.Prelude
 
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Ppr
-import GHC.Driver.Env
-
 import GHC.Tc.Types
 import GHC.Tc.Utils.Env
 
@@ -29,11 +27,7 @@ import GHC.Core.Unfold
 import GHC.Core.Unfold.Make
 import GHC.Core.FVs
 import GHC.Core.Tidy
-import GHC.Core.Opt.Monad
-import GHC.Core.Stats   (coreBindsStats, CoreStats(..))
 import GHC.Core.Seq     (seqBinds)
-import GHC.Core.Lint
-import GHC.Core.Rules
 import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )
 import GHC.Core.InstEnv
 import GHC.Core.Type     ( tidyTopType )
@@ -64,7 +58,6 @@ import GHC.Types.Basic
 import GHC.Types.Name hiding (varName)
 import GHC.Types.Name.Set
 import GHC.Types.Name.Cache
-import GHC.Types.Name.Ppr
 import GHC.Types.Avail
 import GHC.Types.Tickish
 import GHC.Types.TypeEnv
@@ -80,7 +73,6 @@ import Control.Monad
 import Data.Function
 import Data.List        ( sortBy, mapAccumL )
 import qualified Data.Set as S
-import GHC.Platform.Ways
 import GHC.Types.CostCentre
 
 {-
@@ -303,8 +295,7 @@ binder
     [Even non-exported things need system-wide Uniques because the
     byte-code generator builds a single Name->BCO symbol table.]
 
-    We use the NameCache kept in the HscEnv as the
-    source of such system-wide uniques.
+    We use the given NameCache as the source of such system-wide uniques.
 
     For external Ids, use the original-name cache in the NameCache
     to ensure that the unique assigned is the same as the Id had
@@ -348,145 +339,125 @@ three places this is actioned:
   load a compulsory unfolding
 -}
 
-tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env  (ModGuts { mg_module           = mod
-                              , mg_exports          = exports
-                              , mg_rdr_env          = rdr_env
-                              , mg_tcs              = tcs
-                              , mg_insts            = cls_insts
-                              , mg_fam_insts        = fam_insts
-                              , mg_binds            = binds
-                              , mg_patsyns          = patsyns
-                              , mg_rules            = imp_rules
-                              , mg_anns             = anns
-                              , mg_complete_matches = complete_matches
-                              , mg_deps             = deps
-                              , mg_foreign          = foreign_stubs
-                              , mg_foreign_files    = foreign_files
-                              , mg_hpc_info         = hpc_info
-                              , mg_modBreaks        = modBreaks
-                              , mg_boot_exports     = boot_exports
-                              })
-
-  = Err.withTiming logger
-                   (text "CoreTidy"<+>brackets (ppr mod))
-                   (const ()) $!
-    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
-              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
-              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
-              ; implicit_binds = concatMap getImplicitBinds tcs
-              }
-
-        ; (unfold_env, tidy_occ_env)
-              <- chooseExternalIds hsc_env mod omit_prags expose_all
-                                   binds implicit_binds imp_rules
-        ; let { (trimmed_binds, trimmed_rules)
-                    = findExternalRules omit_prags binds imp_rules unfold_env }
-
-        ; let uf_opts = unfoldingOpts dflags
-        ; (tidy_env, tidy_binds)
-                 <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
-
-          -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-        ; (spt_entries, tidy_binds') <-
-             sptCreateStaticBinds hsc_env mod tidy_binds
-        ; let { platform = targetPlatform (hsc_dflags hsc_env)
-              ; spt_init_code = sptModuleInitCode platform mod spt_entries
-              ; add_spt_init_code =
-                  case backend dflags of
-                    -- If we are compiling for the interpreter we will insert
-                    -- any necessary SPT entries dynamically
-                    Interpreter -> id
-                    -- otherwise add a C stub to do so
-                    _              -> (`appendStubC` spt_init_code)
-
-              -- The completed type environment is gotten from
-              --      a) the types and classes defined here (plus implicit things)
-              --      b) adding Ids with correct IdInfo, including unfoldings,
-              --              gotten from the bindings
-              -- From (b) we keep only those Ids with External names;
-              --          the CoreTidy pass makes sure these are all and only
-              --          the externally-accessible ones
-              -- This truncates the type environment to include only the
-              -- exported Ids and things needed from them, which saves space
-              --
-              -- See Note [Don't attempt to trim data types]
-              ; final_ids  = [ trimId omit_prags id
-                             | id <- bindersOfBinds tidy_binds
-                             , isExternalName (idName id)
-                             , not (isWiredIn id)
-                             ]   -- See Note [Drop wired-in things]
-
-              ; final_tcs      = filterOut isWiredIn tcs
-                                 -- See Note [Drop wired-in things]
-              ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts
-              ; tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts
-              ; tidy_rules     = tidyRules tidy_env trimmed_rules
-
-              ; -- See Note [Injecting implicit bindings]
-                all_tidy_binds = implicit_binds ++ tidy_binds'
-
-              -- Get the TyCons to generate code for.  Careful!  We must use
-              -- the untidied TyCons here, because we need
-              --  (a) implicit TyCons arising from types and classes defined
-              --      in this module
-              --  (b) wired-in TyCons, which are normally removed from the
-              --      TypeEnv we put in the ModDetails
-              --  (c) Constructors even if they are not exported (the
-              --      tidied TypeEnv has trimmed these away)
-              ; alg_tycons = filter isAlgTyCon tcs
-
-
-              ; local_ccs
-                  | ways dflags `hasWay` WayProf
-                        = collectCostCentres mod all_tidy_binds tidy_rules
-                  | otherwise
-                        = S.empty
-              }
-
-        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
-
-          -- If the endPass didn't print the rules, but ddump-rules is
-          -- on, print now
-        ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $
-            Logger.putDumpFileMaybe logger Opt_D_dump_rules
-              (showSDoc dflags (ppr CoreTidy <+> text "rules"))
-              FormatText
-              (pprRulesForUser tidy_rules)
-
-          -- Print one-line size info
-        ; let cs = coreBindsStats tidy_binds
-        ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
-            FormatText
-            (text "Tidy size (terms,types,coercions)"
-             <+> ppr (moduleName mod) <> colon
-             <+> int (cs_tm cs)
-             <+> int (cs_ty cs)
-             <+> int (cs_co cs) )
-
-        ; return (CgGuts { cg_module   = mod,
-                           cg_tycons   = alg_tycons,
-                           cg_binds    = all_tidy_binds,
-                           cg_ccs      = S.toList local_ccs,
-                           cg_foreign  = add_spt_init_code foreign_stubs,
-                           cg_foreign_files = foreign_files,
-                           cg_dep_pkgs = dep_direct_pkgs deps,
-                           cg_hpc_info = hpc_info,
-                           cg_modBreaks = modBreaks,
-                           cg_spt_entries = spt_entries },
-
-                   ModDetails { md_types            = tidy_type_env,
-                                md_rules            = tidy_rules,
-                                md_insts            = tidy_cls_insts,
-                                md_fam_insts        = fam_insts,
-                                md_exports          = exports,
-                                md_anns             = anns,      -- are already tidy
-                                md_complete_matches = complete_matches
-                              })
-        }
-  where
-    dflags = hsc_dflags hsc_env
-    logger = hsc_logger hsc_env
+data UnfoldingExposure
+  = ExposeNone -- ^ Don't expose unfoldings
+  | ExposeSome -- ^ Only expose required unfoldings
+  | ExposeAll  -- ^ Expose all unfoldings
+  deriving (Show,Eq,Ord)
+
+data TidyOpts = TidyOpts
+  { opt_name_cache        :: !NameCache
+  , opt_collect_ccs       :: !Bool
+  , opt_unfolding_opts    :: !UnfoldingOpts
+  , opt_expose_unfoldings :: !UnfoldingExposure
+      -- ^ Which unfoldings to expose
+  , opt_trim_ids :: !Bool
+      -- ^ trim off the arity, one-shot-ness, strictness etc which were
+      -- retained for the benefit of the code generator
+  , opt_expose_rules :: !Bool
+      -- ^ Are rules exposed or not?
+  , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)
+      -- ^ Options for generated static pointers, if enabled (/= Nothing).
+  }
+
+tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
+tidyProgram opts (ModGuts { mg_module           = mod
+                          , mg_exports          = exports
+                          , mg_tcs              = tcs
+                          , mg_insts            = cls_insts
+                          , mg_fam_insts        = fam_insts
+                          , mg_binds            = binds
+                          , mg_patsyns          = patsyns
+                          , mg_rules            = imp_rules
+                          , mg_anns             = anns
+                          , mg_complete_matches = complete_matches
+                          , mg_deps             = deps
+                          , mg_foreign          = foreign_stubs
+                          , mg_foreign_files    = foreign_files
+                          , mg_hpc_info         = hpc_info
+                          , mg_modBreaks        = modBreaks
+                          , mg_boot_exports     = boot_exports
+                          }) = do
+
+  let implicit_binds = concatMap getImplicitBinds tcs
+
+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules
+  let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env
+
+  let uf_opts = opt_unfolding_opts opts
+  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
+
+  -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
+  (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
+    Nothing    -> pure ([], Nothing, tidy_binds)
+    Just sopts -> sptCreateStaticBinds sopts mod tidy_binds
+
+  let all_foreign_stubs = case mcstub of
+        Nothing    -> foreign_stubs
+        Just cstub -> foreign_stubs `appendStubC` cstub
+
+      -- The completed type environment is gotten from
+      --      a) the types and classes defined here (plus implicit things)
+      --      b) adding Ids with correct IdInfo, including unfoldings,
+      --              gotten from the bindings
+      -- From (b) we keep only those Ids with External names;
+      --          the CoreTidy pass makes sure these are all and only
+      --          the externally-accessible ones
+      -- This truncates the type environment to include only the
+      -- exported Ids and things needed from them, which saves space
+      --
+      -- See Note [Don't attempt to trim data types]
+      final_ids  = [ trimId (opt_trim_ids opts) id
+                   | id <- bindersOfBinds tidy_binds
+                   , isExternalName (idName id)
+                   , not (isWiredIn id)
+                   ]   -- See Note [Drop wired-in things]
+
+      final_tcs      = filterOut isWiredIn tcs
+                       -- See Note [Drop wired-in things]
+      tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts
+      tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts
+      tidy_rules     = tidyRules tidy_env trimmed_rules
+
+      -- See Note [Injecting implicit bindings]
+      all_tidy_binds = implicit_binds ++ tidy_binds'
+
+      -- Get the TyCons to generate code for.  Careful!  We must use
+      -- the untidied TyCons here, because we need
+      --  (a) implicit TyCons arising from types and classes defined
+      --      in this module
+      --  (b) wired-in TyCons, which are normally removed from the
+      --      TypeEnv we put in the ModDetails
+      --  (c) Constructors even if they are not exported (the
+      --      tidied TypeEnv has trimmed these away)
+      alg_tycons = filter isAlgTyCon tcs
+
+      local_ccs
+        | opt_collect_ccs opts
+              = collectCostCentres mod all_tidy_binds tidy_rules
+        | otherwise
+              = S.empty
+
+  return (CgGuts { cg_module        = mod
+                 , cg_tycons        = alg_tycons
+                 , cg_binds         = all_tidy_binds
+                 , cg_ccs           = S.toList local_ccs
+                 , cg_foreign       = all_foreign_stubs
+                 , cg_foreign_files = foreign_files
+                 , cg_dep_pkgs      = dep_direct_pkgs deps
+                 , cg_hpc_info      = hpc_info
+                 , cg_modBreaks     = modBreaks
+                 , cg_spt_entries   = spt_entries
+                 }
+         , ModDetails { md_types            = tidy_type_env
+                      , md_rules            = tidy_rules
+                      , md_insts            = tidy_cls_insts
+                      , md_fam_insts        = fam_insts
+                      , md_exports          = exports
+                      , md_anns             = anns      -- are already tidy
+                      , md_complete_matches = complete_matches
+                      }
+         )
 
 
 ------------------------------------------------------------------------------
@@ -541,8 +512,8 @@ trimId :: Bool -> Id -> Id
 -- etc which tidyTopIdInfo retains for the benefit of the code generator
 -- but which we don't want in the interface file or ModIface for
 -- downstream compilations
-trimId omit_prags id
-  | omit_prags, not (isImplicitId id)
+trimId do_trim id
+  | do_trim, not (isImplicitId id)
   = id `setIdInfo`      vanillaIdInfo
        `setIdUnfolding` idUnfolding id
        -- We respect the final unfolding chosen by tidyTopIdInfo.
@@ -673,21 +644,20 @@ type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
   --
   -- Bool => expose unfolding or not.
 
-chooseExternalIds :: HscEnv
+chooseExternalIds :: TidyOpts
                   -> Module
-                  -> Bool -> Bool
                   -> [CoreBind]
                   -> [CoreBind]
                   -> [CoreRule]
                   -> IO (UnfoldEnv, TidyOccEnv)
                   -- Step 1 from the notes above
 
-chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
+chooseExternalIds opts mod binds implicit_binds imp_id_rules
   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
        ; tidy_internal internal_ids unfold_env1 occ_env1 }
  where
-  name_cache = hsc_NC hsc_env
+  name_cache = opt_name_cache opts
 
   -- init_ext_ids is the initial list of Ids that should be
   -- externalised.  It serves as the starting point for finding a
@@ -701,18 +671,14 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
 
   -- An Id should be external if either (a) it is exported,
-  -- (b) it appears in the RHS of a local rule for an imported Id, or
-  -- See Note [Which rules to expose]
-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
-
-  rule_rhs_vars
-    -- No rules are exposed when omit_prags is enabled see #19836
-    -- imp_id_rules are the RULES in /this/ module for /imported/ Ids
-    -- If omit_prags is True, these rules won't be put in the interface file.
-    -- But if omit_prags is False, so imp_id_rules are in the interface file for
-    -- this module, then the local-defined Ids they use must be made external.
-    | omit_prags = emptyVarSet
-    | otherwise = mapUnionVarSet ruleRhsFreeVars imp_id_rules
+  -- (b) local rules are exposed and it appears in the RHS of a local rule for
+  -- an imported Id, or See Note [Which rules to expose]
+  is_external id
+    | isExportedId id       = True
+    | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars
+    | otherwise             = False
+
+  rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
 
   binders          = map fst $ flattenBinds binds
   implicit_binders = bindersOfBinds implicit_binds
@@ -758,7 +724,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
     | otherwise = do
       (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
       let
-          (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id
+          (new_ids, show_unfold) = addExternal opts refined_id
 
                 -- 'idocc' is an *occurrence*, but we need to see the
                 -- unfolding in the *definition*; so look up in binder_set
@@ -780,9 +746,9 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
       let unfold_env' = extendVarEnv unfold_env id (name',False)
       tidy_internal ids unfold_env' occ_env'
 
-addExternal :: Bool -> Bool -> Id -> ([Id], Bool)
-addExternal omit_prags expose_all id
-  | omit_prags
+addExternal :: TidyOpts -> Id -> ([Id], Bool)
+addExternal opts id
+  | ExposeNone <- opt_expose_unfoldings opts
   , not (isCompulsoryUnfolding unfolding)
   = ([], False)  -- See Note [Always expose compulsory unfoldings]
                  -- in GHC.HsToCore
@@ -804,8 +770,9 @@ addExternal omit_prags expose_all id
         -- In GHCi the unfolding is used by importers
 
     show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
-       =  expose_all         -- 'expose_all' says to expose all
-                             -- unfoldings willy-nilly
+       = opt_expose_unfoldings opts == ExposeAll
+            -- 'ExposeAll' says to expose all
+            -- unfoldings willy-nilly
 
        || isStableSource src     -- Always expose things whose
                                  -- source is an inline rule
@@ -1000,13 +967,13 @@ called in the final code), we keep the rule too.
 This stuff is the only reason for the ru_auto field in a Rule.
 -}
 
-findExternalRules :: Bool       -- Omit pragmas
+findExternalRules :: TidyOpts
                   -> [CoreBind]
                   -> [CoreRule] -- Local rules for imported fns
                   -> UnfoldEnv  -- Ids that are exported, so we need their rules
                   -> ([CoreBind], [CoreRule])
 -- See Note [Finding external rules]
-findExternalRules omit_prags binds imp_id_rules unfold_env
+findExternalRules opts binds imp_id_rules unfold_env
   = (trimmed_binds, filter keep_rule all_rules)
   where
     imp_rules         = filter expose_rule imp_id_rules
@@ -1031,7 +998,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
         --      been discarded; see Note [Trimming auto-rules]
 
     expose_rule rule
-        | omit_prags = False
+        | 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
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index 4751ae9ea6..ab29a395da 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ViewPatterns  #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Code generation for the Static Pointer Table
 --
@@ -48,9 +48,11 @@
 --
 
 module GHC.Iface.Tidy.StaticPtrTable
-    ( sptCreateStaticBinds
-    , sptModuleInitCode
-    ) where
+  ( sptCreateStaticBinds
+  , sptModuleInitCode
+  , StaticPtrOpts (..)
+  )
+where
 
 {- Note [Grand plan for static forms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -126,36 +128,34 @@ Here is a running example:
 import GHC.Prelude
 import GHC.Platform
 
-import GHC.Driver.Session
-import GHC.Driver.Env
-
 import GHC.Core
 import GHC.Core.Utils (collectMakeStaticArgs)
 import GHC.Core.DataCon
-import GHC.Core.Make (mkStringExprFSWith)
+import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..))
 import GHC.Core.Type
 
 import GHC.Cmm.CLabel
 
 import GHC.Unit.Module
 import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Builtin.Names
-import GHC.Tc.Utils.Env (lookupGlobal)
 
 import GHC.Linker.Types
 
-import GHC.Types.Name
 import GHC.Types.Id
-import GHC.Types.TyThing
 import GHC.Types.ForeignStubs
+import GHC.Data.Maybe
 
-import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Strict
 import Data.List (intercalate)
-import Data.Maybe
 import GHC.Fingerprint
-import qualified GHC.LanguageExtensions as LangExt
+
+data StaticPtrOpts = StaticPtrOpts
+  { opt_platform                :: !Platform    -- ^ Target platform
+  , opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not
+  , opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`
+  , opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon
+  , opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon
+  }
 
 -- | Replaces all bindings of the form
 --
@@ -170,16 +170,13 @@ import qualified GHC.LanguageExtensions as LangExt
 --
 -- It also yields the C stub that inserts these bindings into the static
 -- pointer table.
-sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
-                     -> IO ([SptEntry], CoreProgram)
-sptCreateStaticBinds hsc_env this_mod binds
-    | not (xopt LangExt.StaticPointers dflags) =
-      return ([], binds)
-    | otherwise = do
-      -- Make sure the required interface files are loaded.
-      _ <- lookupGlobal hsc_env unpackCStringName
+sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)
+sptCreateStaticBinds opts this_mod binds = do
       (fps, binds') <- evalStateT (go [] [] binds) 0
-      return (fps, binds')
+      let cstub
+            | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps)
+            | otherwise          = Nothing
+      return (fps, cstub, binds')
   where
     go fps bs xs = case xs of
       []        -> return (reverse fps, reverse bs)
@@ -187,8 +184,6 @@ sptCreateStaticBinds hsc_env this_mod binds
         (fps', bnd') <- replaceStaticBind bnd
         go (reverse fps' ++ fps) (bnd' : bs) xs'
 
-    dflags = hsc_dflags hsc_env
-
     -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
     --
     -- The 'Int' state is used to produce a different key for each binding.
@@ -214,19 +209,16 @@ sptCreateStaticBinds hsc_env this_mod binds
     mkStaticBind t srcLoc e = do
       i <- get
       put (i + 1)
-      staticPtrInfoDataCon <-
-        lift $ lookupDataConHscEnv staticPtrInfoDataConName
+      let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts
       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
-      info <- mkConApp staticPtrInfoDataCon <$>
-            (++[srcLoc]) <$>
-            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
-                 [ unitFS $ moduleUnit this_mod
-                 , moduleNameFS $ moduleName this_mod
-                 ]
-
-      -- The module interface of GHC.StaticPtr should be loaded at least
-      -- when looking up 'fromStatic' during type-checking.
-      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
+      let mk_string_fs = mkStringExprFSWith (opt_mk_string opts)
+      let info = mkConApp staticPtrInfoDataCon
+                  [ mk_string_fs $ unitFS $ moduleUnit this_mod
+                  , mk_string_fs $ moduleNameFS $ moduleName this_mod
+                  , srcLoc
+                  ]
+
+      let staticPtrDataCon = opt_static_ptr_datacon opts
       return (fp, mkConApp staticPtrDataCon
                                [ Type t
                                , mkWord64LitWord64 w0
@@ -241,17 +233,6 @@ sptCreateStaticBinds hsc_env this_mod binds
         , show n
         ]
 
-    lookupIdHscEnv :: Name -> IO Id
-    lookupIdHscEnv n = lookupType hsc_env n >>=
-                         maybe (getError n) (return . tyThingId)
-
-    lookupDataConHscEnv :: Name -> IO DataCon
-    lookupDataConHscEnv n = lookupType hsc_env n >>=
-                              maybe (getError n) (return . tyThingDataCon)
-
-    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
-      text "Couldn't find" <+> ppr n
-
 -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
 -- of @module@ into the static pointer table.
 --
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index c02e56b291..9aae391a1b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -394,6 +394,7 @@ Library
         GHC.Driver.Config.Stg.Pipeline
         GHC.Driver.Config.Stg.Ppr
         GHC.Driver.Config.StgToCmm
+        GHC.Driver.Config.Tidy
         GHC.Driver.Env
         GHC.Driver.Env.KnotVars
         GHC.Driver.Env.Types