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.

3 files changed, 49 insertions, 19 deletions

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 ()