module GHC.Driver.Config.Stg.Pipeline
  ( initStgPipelineOpts
  ) where

import GHC.Prelude

import Control.Monad (guard)

import GHC.Stg.Pipeline
import GHC.Stg.Utils

import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Stg.Lift
import GHC.Driver.Config.Stg.Ppr
import GHC.Driver.DynFlags

-- | Initialize STG pretty-printing options from DynFlags
initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
initStgPipelineOpts DynFlags
dflags Bool
for_bytecode =
  let !platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      !ext_dyn_refs :: Bool
ext_dyn_refs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs DynFlags
dflags
  in StgPipelineOpts
    { stgPipeline_lint :: Maybe DiagOpts
stgPipeline_lint = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoStgLinting DynFlags
dflags
        DiagOpts -> Maybe DiagOpts
forall a. a -> Maybe a
Just (DiagOpts -> Maybe DiagOpts) -> DiagOpts -> Maybe DiagOpts
forall a b. (a -> b) -> a -> b
$ DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    , stgPipeline_pprOpts :: StgPprOpts
stgPipeline_pprOpts = DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags
    , stgPipeline_phases :: [StgToDo]
stgPipeline_phases = Bool -> DynFlags -> [StgToDo]
getStgToDo Bool
for_bytecode DynFlags
dflags
    , stgPlatform :: Platform
stgPlatform = Platform
platform
    , stgPipeline_forBytecode :: Bool
stgPipeline_forBytecode = Bool
for_bytecode
    , stgPipeline_allowTopLevelConApp :: Module -> DataCon -> [StgArg] -> Bool
stgPipeline_allowTopLevelConApp = Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
allowTopLevelConApp Platform
platform Bool
ext_dyn_refs
    }

-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo
  :: Bool -- ^ Are we preparing for bytecode?
  -> DynFlags
  -> [StgToDo]
getStgToDo :: Bool -> DynFlags -> [StgToDo]
getStgToDo Bool
for_bytecode DynFlags
dflags =
  (StgToDo -> Bool) -> [StgToDo] -> [StgToDo]
forall a. (a -> Bool) -> [a] -> [a]
filter (StgToDo -> StgToDo -> Bool
forall a. Eq a => a -> a -> Bool
/= StgToDo
StgDoNothing)
    [ StgToDo -> StgToDo
forall {a}. a -> a
mandatory StgToDo
StgUnarise
    -- Important that unarisation comes first
    -- See Note [StgCse after unarisation] in GHC.Stg.CSE
    , GeneralFlag -> StgToDo -> StgToDo
optional GeneralFlag
Opt_StgCSE StgToDo
StgCSE
    , GeneralFlag -> StgToDo -> StgToDo
optional GeneralFlag
Opt_StgLiftLams (StgToDo -> StgToDo) -> StgToDo -> StgToDo
forall a b. (a -> b) -> a -> b
$ StgLiftConfig -> StgToDo
StgLiftLams (StgLiftConfig -> StgToDo) -> StgLiftConfig -> StgToDo
forall a b. (a -> b) -> a -> b
$ DynFlags -> StgLiftConfig
initStgLiftConfig DynFlags
dflags
    , Bool -> StgToDo -> StgToDo
runWhen Bool
for_bytecode StgToDo
StgBcPrep
    , GeneralFlag -> StgToDo -> StgToDo
optional GeneralFlag
Opt_StgStats StgToDo
StgStats
    ] where
      optional :: GeneralFlag -> StgToDo -> StgToDo
optional GeneralFlag
opt = Bool -> StgToDo -> StgToDo
runWhen (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
opt DynFlags
dflags)
      mandatory :: a -> a
mandatory = a -> a
forall {a}. a -> a
id

runWhen :: Bool -> StgToDo -> StgToDo
runWhen :: Bool -> StgToDo -> StgToDo
runWhen Bool
True StgToDo
todo = StgToDo
todo
runWhen Bool
_    StgToDo
_    = StgToDo
StgDoNothing