From 37d435d263832ffb2808dad0ccd50110c9f0c430 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 4 Feb 2022 03:00:12 +0000 Subject: 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. --- compiler/GHC/Stg/Lift/Analysis.hs | 14 +++++++------- compiler/GHC/Stg/Lift/Config.hs | 22 ++++++++++++++++++++++ compiler/GHC/Stg/Lift/Monad.hs | 32 ++++++++++++++++++++------------ 3 files changed, 49 insertions(+), 19 deletions(-) create mode 100644 compiler/GHC/Stg/Lift/Config.hs (limited to 'compiler/GHC/Stg/Lift') 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 () -- cgit v1.2.1