diff options
author | John Ericson <John.Ericson@Obsidian.Systems> | 2022-02-04 03:00:12 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-02-06 01:44:32 -0500 |
commit | 37d435d263832ffb2808dad0ccd50110c9f0c430 (patch) | |
tree | 0c3d046be6575f184cb4e768e2611b31db4d355a | |
parent | 633296bca950f0ef17313f8487d2f5ddd369bc4f (diff) | |
download | haskell-37d435d263832ffb2808dad0ccd50110c9f0c430.tar.gz |
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.
-rw-r--r-- | compiler/GHC/CoreToStg.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Stg/Debug.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Stg/Lift.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Stg/Pipeline.hs | 46 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Stg/Ppr.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Platform.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Platform/Profile.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Platform/Ways.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Stg/Debug.hs | 29 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Analysis.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Config.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Monad.hs | 32 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lint.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Stg/Pipeline.hs | 65 | ||||
-rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 9 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 5 | ||||
-rw-r--r-- | libraries/ghc-boot/GHC/Platform/ArchOS.hs | 14 | ||||
-rw-r--r-- | utils/deriveConstants/Main.hs | 2 |
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"] |