Purge DynFlags from GHC.Stg

Also derive some more instances. GHC doesn't need them, but downstream
consumers may need to e.g. put stuff in maps.

5 files changed, 92 insertions, 1 deletions

diff --git a/compiler/GHC/Driver/Config/Stg/Debug.hs b/compiler/GHC/Driver/Config/Stg/Debug.hs
new file mode 100644
index 0000000000..b680dc148f
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Stg/Debug.hs
@@ -0,0 +1,14 @@
+module GHC.Driver.Config.Stg.Debug
+  ( initStgDebugOpts
+  ) where
+
+import GHC.Stg.Debug
+
+import GHC.Driver.Session
+
+-- | Initialize STG pretty-printing options from DynFlags
+initStgDebugOpts :: DynFlags -> StgDebugOpts
+initStgDebugOpts dflags = StgDebugOpts
+  { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags
+  , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags
+  }
diff --git a/compiler/GHC/Driver/Config/Stg/Lift.hs b/compiler/GHC/Driver/Config/Stg/Lift.hs
new file mode 100644
index 0000000000..04155a27d1
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Stg/Lift.hs
@@ -0,0 +1,15 @@
+module GHC.Driver.Config.Stg.Lift
+  ( initStgLiftConfig
+  ) where
+
+import GHC.Stg.Lift.Config
+
+import GHC.Driver.Session
+
+initStgLiftConfig :: DynFlags -> StgLiftConfig
+initStgLiftConfig dflags = StgLiftConfig
+    { c_targetProfile      = targetProfile dflags
+    , c_liftLamsRecArgs    = liftLamsRecArgs dflags
+    , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags
+    , c_liftLamsKnown      = liftLamsKnown dflags
+    }
diff --git a/compiler/GHC/Driver/Config/Stg/Pipeline.hs b/compiler/GHC/Driver/Config/Stg/Pipeline.hs
new file mode 100644
index 0000000000..5ab9548786
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Stg/Pipeline.hs
@@ -0,0 +1,46 @@
+module GHC.Driver.Config.Stg.Pipeline
+  ( initStgPipelineOpts
+  ) where
+
+import GHC.Prelude
+
+import Control.Monad (guard)
+
+import GHC.Stg.Pipeline
+
+import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Config.Stg.Lift
+import GHC.Driver.Config.Stg.Ppr
+import GHC.Driver.Session
+
+-- | Initialize STG pretty-printing options from DynFlags
+initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
+initStgPipelineOpts dflags for_bytecode = StgPipelineOpts
+  { stgPipeline_lint = do
+      guard $ gopt Opt_DoStgLinting dflags
+      Just $ initDiagOpts dflags
+  , stgPipeline_pprOpts = initStgPprOpts dflags
+  , stgPipeline_phases = getStgToDo for_bytecode dflags
+  }
+
+-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
+getStgToDo
+  :: Bool -- ^ Are we preparing for bytecode?
+  -> DynFlags
+  -> [StgToDo]
+getStgToDo for_bytecode dflags =
+  filter (/= StgDoNothing)
+    [ mandatory StgUnarise
+    -- Important that unarisation comes first
+    -- See Note [StgCse after unarisation] in GHC.Stg.CSE
+    , optional Opt_StgCSE StgCSE
+    , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags
+    , runWhen for_bytecode StgBcPrep
+    , optional Opt_StgStats StgStats
+    ] where
+      optional opt = runWhen (gopt opt dflags)
+      mandatory = id
+
+runWhen :: Bool -> StgToDo -> StgToDo
+runWhen True todo = todo
+runWhen _    _    = StgDoNothing
diff --git a/compiler/GHC/Driver/Config/Stg/Ppr.hs b/compiler/GHC/Driver/Config/Stg/Ppr.hs
new file mode 100644
index 0000000000..6f044afdf4
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Stg/Ppr.hs
@@ -0,0 +1,13 @@
+module GHC.Driver.Config.Stg.Ppr
+  ( initStgPprOpts
+  ) where
+
+import GHC.Stg.Syntax
+
+import GHC.Driver.Session
+
+-- | Initialize STG pretty-printing options from DynFlags
+initStgPprOpts :: DynFlags -> StgPprOpts
+initStgPprOpts dflags = StgPprOpts
+   { stgSccEnabled = sccProfilingEnabled dflags
+   }
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3e48771ace..c3acea5d88 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -106,6 +106,8 @@ import GHC.Driver.Errors.Types
 import GHC.Driver.CodeOutput
 import GHC.Driver.Config.Logger   (initLogFlags)
 import GHC.Driver.Config.Parser   (initParserOpts)
+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.Hooks
@@ -1867,7 +1869,8 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
 
     stg_binds_with_fvs
         <- {-# SCC "Stg2Stg" #-}
-           stg2stg logger dflags ictxt for_bytecode this_mod stg_binds
+           stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)
+                   this_mod stg_binds
 
     return (stg_binds_with_fvs, denv, cost_centre_info)