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

2 files changed, 122 insertions, 4 deletions

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)
+
 
 {- **********************************************************************
 %*                                                                      *