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.

20 files changed, 218 insertions, 97 deletions

diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 0f6ac1121d..431d831125 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -18,6 +18,7 @@ module GHC.CoreToStg ( coreToStg ) where
 import GHC.Prelude
 
 import GHC.Driver.Session
+import GHC.Driver.Config.Stg.Debug
 
 import GHC.Core
 import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
@@ -244,7 +245,7 @@ coreToStg dflags this_mod ml pgm
     -- See Note [Mapping Info Tables to Source Positions]
     (!pgm'', !denv) =
         if gopt Opt_InfoTableMap dflags
-          then collectDebugInformation dflags ml pgm'
+          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'
           else (pgm', emptyInfoTableProvMap)
 
     prof = ways dflags `hasWay` WayProf
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)
 
diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs
index 4faf20d24e..0c2e6df5c4 100644
--- a/compiler/GHC/Platform.hs
+++ b/compiler/GHC/Platform.hs
@@ -82,7 +82,7 @@ data Platform = Platform
    , platform_constants               :: !(Maybe PlatformConstants)
       -- ^ Constants such as structure offsets, type sizes, etc.
    }
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 platformConstants :: Platform -> PlatformConstants
 platformConstants platform = case platform_constants platform of
diff --git a/compiler/GHC/Platform/Profile.hs b/compiler/GHC/Platform/Profile.hs
index b9011d35b5..d474ff34c8 100644
--- a/compiler/GHC/Platform/Profile.hs
+++ b/compiler/GHC/Platform/Profile.hs
@@ -23,6 +23,7 @@ data Profile = Profile
    { profilePlatform :: !Platform -- ^ Platform
    , profileWays     :: !Ways     -- ^ Ways
    }
+  deriving (Eq, Ord, Show, Read)
 
 -- | Get platform constants
 profileConstants :: Profile -> PlatformConstants
diff --git a/compiler/GHC/Platform/Ways.hs b/compiler/GHC/Platform/Ways.hs
index 71337187d8..6bb8aed87f 100644
--- a/compiler/GHC/Platform/Ways.hs
+++ b/compiler/GHC/Platform/Ways.hs
@@ -70,7 +70,7 @@ data Way
   | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports
   | WayTracing       -- ^ (RTS only) enable event logging (tracing)
   | WayDyn           -- ^ Dynamic linking
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Read)
 
 type Ways = Set Way
 
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index bea6fe5c8e..8452642288 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -1,8 +1,11 @@
 {-# LANGUAGE TupleSections #-}
+
 -- This module contains functions which implement
 -- the -finfo-table-map and -fdistinct-constructor-tables flags
-module GHC.Stg.Debug(collectDebugInformation) where
-
+module GHC.Stg.Debug
+  ( StgDebugOpts(..)
+  , collectDebugInformation
+  ) where
 
 import GHC.Prelude
 
@@ -15,7 +18,6 @@ import GHC.Types.IPE
 import GHC.Unit.Module
 import GHC.Types.Name   ( getName, getOccName, occNameString, nameSrcSpan)
 import GHC.Data.FastString
-import GHC.Driver.Session
 
 import Control.Monad (when)
 import Control.Monad.Trans.Reader
@@ -29,7 +31,12 @@ import Data.List.NonEmpty (NonEmpty(..))
 
 data SpanWithLabel = SpanWithLabel RealSrcSpan String
 
-data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }
+data StgDebugOpts = StgDebugOpts
+  { stgDebug_infoTableMap              :: !Bool
+  , stgDebug_distinctConstructorTables :: !Bool
+  }
+
+data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }
 
 type M a = ReaderT R (State InfoTableProvMap) a
 
@@ -44,9 +51,9 @@ withSpan (new_s, new_l) act = local maybe_replace act
     maybe_replace r
       = r { rSpan = Just (SpanWithLabel new_s new_l) }
 
-collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
-collectDebugInformation dflags ml bs =
-    runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap
+collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
+collectDebugInformation opts ml bs =
+    runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap
 
 collectTop :: StgTopBinding -> M StgTopBinding
 collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t
@@ -128,8 +135,8 @@ quickSourcePos _ _ = Nothing
 
 recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
 recordStgIdPosition id best_span ss = do
-  dflags <- asks rDynFlags
-  when (gopt Opt_InfoTableMap dflags) $ do
+  opts <- asks rOpts
+  when (stgDebug_infoTableMap opts) $ do
     cc <- asks rSpan
     --Useful for debugging why a certain Id gets given a certain span
     --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
@@ -142,8 +149,8 @@ numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber
 numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber
 numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber
 numberDataCon dc ts = do
-  dflags <- asks rDynFlags
-  if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do
+  opts <- asks rOpts
+  if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do
     env <- lift get
     mcc <- asks rSpan
     let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index b4c473b50d..8155cd734e 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -11,6 +11,7 @@ module GHC.Stg.Lift
    (
     -- * Late lambda lifting in STG
     -- $note
+   StgLiftConfig (..),
    stgLiftLams
    )
 where
@@ -18,9 +19,9 @@ where
 import GHC.Prelude
 
 import GHC.Types.Basic
-import GHC.Driver.Session
 import GHC.Types.Id
 import GHC.Stg.FVs ( annBindingFreeVars )
+import GHC.Stg.Lift.Config
 import GHC.Stg.Lift.Analysis
 import GHC.Stg.Lift.Monad
 import GHC.Stg.Syntax
@@ -125,8 +126,8 @@ import Data.Maybe ( isNothing )
 --
 -- (Mostly) textbook instance of the lambda lifting transformation, selecting
 -- which bindings to lambda lift by consulting 'goodToLift'.
-stgLiftLams :: Module -> DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
-stgLiftLams this_mod dflags us = runLiftM dflags us . foldr (liftTopLvl this_mod) (pure ())
+stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
+stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ())
 
 liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()
 liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
@@ -168,8 +169,8 @@ withLiftedBindPairs top rec pairs scope k = do
   let (infos, rhss) = unzip pairs
   let bndrs = map binderInfoBndr infos
   expander <- liftedIdsExpander
-  dflags <- getDynFlags
-  case goodToLift dflags top rec expander pairs scope of
+  cfg <- getConfig
+  case goodToLift cfg top rec expander pairs scope of
     -- @abs_ids@ is the set of all variables that need to become parameters.
     Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
       -- Within this block, all binders in @bndrs@ will be noted as lifted, so
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index 5999104c9c..c2eb9dbb2d 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -26,9 +26,9 @@ import GHC.Platform.Profile
 
 import GHC.Types.Basic
 import GHC.Types.Demand
-import GHC.Driver.Session
 import GHC.Types.Id
 import GHC.Runtime.Heap.Layout ( WordOff )
+import GHC.Stg.Lift.Config
 import GHC.Stg.Syntax
 import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep
 import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
@@ -342,7 +342,7 @@ tagSkeletonAlt (con, bndrs, rhs)
 -- | Combines several heuristics to decide whether to lambda-lift a given
 -- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details.
 goodToLift
-  :: DynFlags
+  :: StgLiftConfig
   -> TopLevelFlag
   -> RecFlag
   -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
@@ -352,7 +352,7 @@ goodToLift
   -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
                         -- lift and @abs_ids@ are the variables it would
                         -- abstract over
-goodToLift dflags top_lvl rec_flag expander pairs scope = decide
+goodToLift cfg top_lvl rec_flag expander pairs scope = decide
   [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]
   , ("memoized", any_memoized)
   , ("argument occurrences", arg_occs)
@@ -362,7 +362,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide
   , ("args spill on stack", args_spill_on_stack)
   , ("increases allocation", inc_allocs)
   ] where
-      profile  = targetProfile dflags
+      profile  = c_targetProfile cfg
       platform = profilePlatform profile
       decide deciders
         | not (fancy_or deciders)
@@ -431,7 +431,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide
       -- idArity f > 0 ==> known
       known_fun id = idArity id > 0
       abstracts_known_local_fun
-        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)
+        = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids)
 
       -- Number of arguments of a RHS in the current binding group if we decide
       -- to lift it
@@ -441,8 +441,8 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide
         . (dVarSetElems abs_ids ++)
         . rhsLambdaBndrs
       max_n_args
-        | isRec rec_flag = liftLamsRecArgs dflags
-        | otherwise      = liftLamsNonRecArgs dflags
+        | isRec rec_flag = c_liftLamsRecArgs cfg
+        | otherwise      = c_liftLamsNonRecArgs cfg
       -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
       -- args are passed on the stack, which means slow memory accesses
       args_spill_on_stack
diff --git a/compiler/GHC/Stg/Lift/Config.hs b/compiler/GHC/Stg/Lift/Config.hs
new file mode 100644
index 0000000000..1413bd5edc
--- /dev/null
+++ b/compiler/GHC/Stg/Lift/Config.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Configuration options for Lift the lambda lifter.
+module GHC.Stg.Lift.Config (
+    StgLiftConfig (..),
+  ) where
+
+import GHC.Prelude
+
+import GHC.Platform.Profile
+
+data StgLiftConfig = StgLiftConfig
+  { c_targetProfile         :: !Profile
+  , c_liftLamsRecArgs       :: !(Maybe Int)
+  -- ^ Maximum number of arguments after lambda lifting a recursive function.
+  , c_liftLamsNonRecArgs    :: !(Maybe Int)
+  -- ^ Maximum number of arguments after lambda lifting non-recursive function.
+  , c_liftLamsKnown         :: !Bool
+  -- ^ Lambda lift even when this turns a known call into an unknown call.
+  }
+  deriving (Show, Read, Eq, Ord)
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index 9b29b02ba6..a07c89b513 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -12,6 +12,8 @@ module GHC.Stg.Lift.Monad (
     FloatLang (..), collectFloats, -- Exported just for the docs
     -- * Transformation monad
     LiftM, runLiftM,
+    -- ** Get config
+    getConfig,
     -- ** Adding bindings
     startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
     -- ** Substitution and binders
@@ -24,14 +26,16 @@ import GHC.Prelude
 
 import GHC.Types.Basic
 import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS )
-import GHC.Driver.Session
 import GHC.Data.FastString
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Utils.Outputable
 import GHC.Data.OrdList
+
+import GHC.Stg.Lift.Config
 import GHC.Stg.Subst
 import GHC.Stg.Syntax
+
 import GHC.Core.Utils
 import GHC.Types.Unique.Supply
 import GHC.Utils.Panic
@@ -59,7 +63,7 @@ mkStgBinding NonRecursive = uncurry StgNonRec . head
 -- | Environment threaded around in a scoped, @Reader@-like fashion.
 data Env
   = Env
-  { e_dflags     :: !DynFlags
+  { e_config     :: StgLiftConfig
   -- ^ Read-only.
   , e_subst      :: !Subst
   -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',
@@ -82,8 +86,12 @@ data Env
   -- Invariant: 'Id's not present in this map won't be substituted.
   }
 
-emptyEnv :: DynFlags -> Env
-emptyEnv dflags = Env dflags emptySubst emptyVarEnv
+emptyEnv :: StgLiftConfig -> Env
+emptyEnv cfg = Env
+  { e_config = cfg
+  , e_subst = emptySubst
+  , e_expansions = emptyVarEnv
+  }
 
 
 -- Note [Handling floats]
@@ -200,8 +208,8 @@ removeRhsCCCS rhs = rhs
 -- | The analysis monad consists of the following 'RWST' components:
 --
 --     * 'Env': Reader-like context. Contains a substitution, info about how
---       how lifted identifiers are to be expanded into applications and details
---       such as 'DynFlags'.
+--       how lifted identifiers are to be expanded into applications and
+--       configuration options.
 --
 --     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.
 --
@@ -214,18 +222,18 @@ newtype LiftM a
   = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }
   deriving (Functor, Applicative, Monad)
 
-instance HasDynFlags LiftM where
-  getDynFlags = LiftM (RWS.asks e_dflags)
-
 instance MonadUnique LiftM where
   getUniqueSupplyM = LiftM (lift getUniqueSupplyM)
   getUniqueM = LiftM (lift getUniqueM)
   getUniquesM = LiftM (lift getUniquesM)
 
-runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]
-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)
+runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding]
+runLiftM cfg us (LiftM m) = collectFloats (fromOL floats)
   where
-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())
+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ())
+
+getConfig :: LiftM StgLiftConfig
+getConfig = LiftM $ e_config <$> RWS.ask
 
 -- | Writes a plain 'StgTopStringLit' to the output.
 addTopStringLit :: OutId -> ByteString -> LiftM ()
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index ecca8a78e2..aa7d03cacc 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -41,9 +41,6 @@ import GHC.Prelude
 
 import GHC.Stg.Syntax
 
-import GHC.Driver.Session
-import GHC.Driver.Config.Diagnostic
-
 import GHC.Core.Lint        ( interactiveInScope )
 import GHC.Core.DataCon
 import GHC.Core             ( AltCon(..) )
@@ -51,6 +48,7 @@ import GHC.Core.Type
 
 import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
 import GHC.Types.CostCentre ( isCurrentCCS )
+import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) )
 import GHC.Types.Id
 import GHC.Types.Var.Set
 import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
@@ -72,7 +70,8 @@ import Control.Monad
 
 lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                    => Logger
-                   -> DynFlags
+                   -> DiagOpts
+                   -> StgPprOpts
                    -> InteractiveContext
                    -> Module -- ^ module being compiled
                    -> Bool   -- ^ have we run Unarise yet?
@@ -80,7 +79,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                    -> [GenStgTopBinding a]
                    -> IO ()
 
-lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
+lintStgTopBindings logger diag_opts opts ictxt this_mod unarised whodunnit binds
   = {-# SCC "StgLint" #-}
     case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
       Nothing  ->
@@ -96,8 +95,6 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
                   text "*** End of Offense ***"])
         Err.ghcExit logger 1
   where
-    diag_opts = initDiagOpts dflags
-    opts = initStgPprOpts dflags
     -- Bring all top-level binds into scope because CoreToStg does not generate
     -- bindings in dependency order (so we may see a use before its definition).
     top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index afd27cb67f..96c3cf3dcd 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -9,7 +9,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module GHC.Stg.Pipeline ( stg2stg ) where
+module GHC.Stg.Pipeline
+  ( StgPipelineOpts (..)
+  , StgToDo (..)
+  , stg2stg
+  ) where
 
 import GHC.Prelude
 
@@ -21,11 +25,11 @@ import GHC.Stg.FVs      ( depSortWithAnnotStgPgm )
 import GHC.Stg.Unarise  ( unarise )
 import GHC.Stg.BcPrep   ( bcPrep )
 import GHC.Stg.CSE      ( stgCse )
-import GHC.Stg.Lift     ( stgLiftLams )
+import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams )
 import GHC.Unit.Module ( Module )
 import GHC.Runtime.Context ( InteractiveContext )
 
-import GHC.Driver.Session
+import GHC.Driver.Flags (DumpFlag(..))
 import GHC.Utils.Error
 import GHC.Types.Unique.Supply
 import GHC.Utils.Outputable
@@ -34,6 +38,14 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 
+data StgPipelineOpts = StgPipelineOpts
+  { stgPipeline_phases      :: ![StgToDo]
+  -- ^ Spec of what stg-to-stg passes to do
+  , stgPipeline_lint        :: !(Maybe DiagOpts)
+  -- ^ Should we lint the STG at various stages of the pipeline?
+  , stgPipeline_pprOpts     :: !StgPprOpts
+  }
+
 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
   deriving (Functor, Applicative, Monad, MonadIO)
 
@@ -47,18 +59,17 @@ runStgM :: Char -> StgM a -> IO a
 runStgM mask (StgM m) = runReaderT m mask
 
 stg2stg :: Logger
-        -> DynFlags                  -- includes spec of what stg-to-stg passes to do
         -> InteractiveContext
-        -> Bool                      -- prepare for bytecode?
+        -> StgPipelineOpts
         -> Module                    -- module being compiled
         -> [StgTopBinding]           -- input program
         -> IO [CgStgTopBinding]        -- output program
-stg2stg logger dflags ictxt for_bytecode this_mod binds
+stg2stg logger ictxt opts this_mod binds
   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
         ; showPass logger "Stg2Stg"
         -- Do the main business!
         ; binds' <- runStgM 'g' $
-            foldM (do_stg_pass this_mod) binds (getStgToDo for_bytecode dflags)
+            foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts)
 
           -- Dependency sort the program as last thing. The program needs to be
           -- in dependency order for the SRT algorithm to work (see
@@ -76,8 +87,11 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
 
   where
     stg_linter unarised
-      | gopt Opt_DoStgLinting dflags
-      = lintStgTopBindings logger dflags ictxt this_mod unarised
+      | Just diag_opts <- stgPipeline_lint opts
+      = lintStgTopBindings
+          logger
+          diag_opts ppr_opts
+          ictxt this_mod unarised
       | otherwise
       = \ _whodunnit _binds -> return ()
 
@@ -95,10 +109,10 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
             let binds' = {-# SCC "StgCse" #-} stgCse binds
             end_pass "StgCse" binds'
 
-          StgLiftLams -> do
+          StgLiftLams cfg -> do
             us <- getUniqueSupplyM
             --
-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod dflags us binds
+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds
             end_pass "StgLiftLams" binds'
 
           StgBcPrep -> do
@@ -114,14 +128,14 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
             liftIO (stg_linter True "Unarise" binds')
             return binds'
 
-    opts = initStgPprOpts dflags
+    ppr_opts = stgPipeline_pprOpts opts
     dump_when flag header binds
-      = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings opts binds)
+      = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)
 
     end_pass what binds2
       = liftIO $ do -- report verbosely, if required
           putDumpFileMaybe logger Opt_D_verbose_stg2stg what
-            FormatSTG (vcat (map (pprStgTopBinding opts) binds2))
+            FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))
           stg_linter False what binds2
           return binds2
 
@@ -132,7 +146,7 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
 data StgToDo
   = StgCSE
   -- ^ Common subexpression elimination
-  | StgLiftLams
+  | StgLiftLams StgLiftConfig
   -- ^ Lambda lifting closure variables, trading stack/register allocation for
   -- heap allocation
   | StgStats
@@ -142,23 +156,4 @@ data StgToDo
   -- ^ Mandatory when compiling to bytecode
   | StgDoNothing
   -- ^ Useful for building up 'getStgToDo'
-  deriving Eq
-
--- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
-getStgToDo :: Bool -> 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
-    , 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
+  deriving (Show, Read, Eq, Ord)
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 5d2b0facc1..bf6bac3853 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -58,7 +58,7 @@ module GHC.Stg.Syntax (
         bindersOf, bindersOfTop, bindersOfTopBinds,
 
         -- ppr
-        StgPprOpts(..), initStgPprOpts,
+        StgPprOpts(..),
         panicStgPprOpts, shortStgPprOpts,
         pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding,
         pprGenStgTopBinding, pprStgTopBinding,
@@ -73,7 +73,6 @@ import Data.ByteString ( ByteString )
 import Data.Data   ( Data )
 import Data.List   ( intersperse )
 import GHC.Core.DataCon
-import GHC.Driver.Session
 import GHC.Types.ForeignCall ( ForeignCall )
 import GHC.Types.Id
 import GHC.Types.Name        ( isDynLinkName )
@@ -683,12 +682,6 @@ data StgPprOpts = StgPprOpts
    { stgSccEnabled :: !Bool -- ^ Enable cost-centres
    }
 
--- | Initialize STG pretty-printing options from DynFlags
-initStgPprOpts :: DynFlags -> StgPprOpts
-initStgPprOpts dflags = StgPprOpts
-   { stgSccEnabled = sccProfilingEnabled dflags
-   }
-
 -- | STG pretty-printing options used for panic messages
 panicStgPprOpts :: StgPprOpts
 panicStgPprOpts = StgPprOpts
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fa934e429e..8dc7de62f7 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -378,6 +378,10 @@ Library
         GHC.Driver.Config.HsToCore
         GHC.Driver.Config.Logger
         GHC.Driver.Config.Parser
+        GHC.Driver.Config.Stg.Debug
+        GHC.Driver.Config.Stg.Lift
+        GHC.Driver.Config.Stg.Pipeline
+        GHC.Driver.Config.Stg.Ppr
         GHC.Driver.Config.StgToCmm
         GHC.Driver.Env
         GHC.Driver.Env.KnotVars
@@ -538,6 +542,7 @@ Library
         GHC.Stg.FVs
         GHC.Stg.Lift
         GHC.Stg.Lift.Analysis
+        GHC.Stg.Lift.Config
         GHC.Stg.Lift.Monad
         GHC.Stg.Lint
         GHC.Stg.Pipeline
diff --git a/libraries/ghc-boot/GHC/Platform/ArchOS.hs b/libraries/ghc-boot/GHC/Platform/ArchOS.hs
index 2673dc6839..c46371fac0 100644
--- a/libraries/ghc-boot/GHC/Platform/ArchOS.hs
+++ b/libraries/ghc-boot/GHC/Platform/ArchOS.hs
@@ -24,7 +24,7 @@ data ArchOS
       { archOS_arch :: Arch
       , archOS_OS   :: OS
       }
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | Architectures
 --
@@ -45,14 +45,14 @@ data Arch
    | ArchMipsel
    | ArchRISCV64
    | ArchJavaScript
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | ARM Instruction Set Architecture
 data ArmISA
    = ARMv5
    | ARMv6
    | ARMv7
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | ARM extensions
 data ArmISAExt
@@ -61,20 +61,20 @@ data ArmISAExt
    | VFPv3D16
    | NEON
    | IWMMX2
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | ARM ABI
 data ArmABI
    = SOFT
    | SOFTFP
    | HARD
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | PowerPC 64-bit ABI
 data PPC_64ABI
    = ELF_V1 -- ^ PowerPC64
    | ELF_V2 -- ^ PowerPC64 LE
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 -- | Operating systems.
 --
@@ -95,7 +95,7 @@ data OS
    | OSQNXNTO
    | OSAIX
    | OSHurd
-   deriving (Read, Show, Eq)
+   deriving (Read, Show, Eq, Ord)
 
 
 -- Note [Platform Syntax]
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 7121e74245..4832ccfc89 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -880,7 +880,7 @@ writeHaskellType fn ws = atomicWriteFile fn xs
                    \import Prelude\n\
                    \import Data.Char\n\n\
                    \data PlatformConstants = PlatformConstants {"
-          footer = "  } deriving (Show,Read,Eq)\n\n"
+          footer = "  } deriving (Show, Read, Eq, Ord)\n\n"
           body = intercalate ",\n" (concatMap doWhat ws)
 
           doWhat (GetClosureSize name _) = ["      pc_" ++ name ++ " :: {-# UNPACK #-} !Int"]