    {-
    (c) The GRASP/AQUA Project, Glasgow University, 1993-1998

    \section[SimplStg]{Driver for simplifying @STG@ programs}
    -}

    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE TypeFamilies #-}

    module GHC.Stg.Pipeline
      ( StgPipelineOpts (..)
      , StgToDo (..)
      , stg2stg
      , StgCgInfos
      ) where

    import GHC.Prelude

    import GHC.Driver.Flags

    import GHC.Stg.Syntax

    import GHC.Stg.Lint     ( lintStgTopBindings )
    import GHC.Stg.Stats    ( showStgStats )
    import GHC.Stg.FVs      ( depSortWithAnnotStgPgm )
    import GHC.Stg.Unarise  ( unarise )
    import GHC.Stg.BcPrep   ( bcPrep )
    import GHC.Stg.CSE      ( stgCse )
    import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams )
    import GHC.Unit.Module ( Module )

    import GHC.Utils.Error
    import GHC.Types.Var
    import GHC.Types.Unique.Supply
    import GHC.Utils.Outputable
    import GHC.Utils.Logger
    import Control.Monad
    import Control.Monad.IO.Class
    import Control.Monad.Trans.Reader
    import GHC.Settings (Platform)
    import GHC.Stg.InferTags (inferTags)
    import GHC.Types.Name.Env (NameEnv)
    import GHC.Stg.InferTags.TagSig (TagSig)

    data StgPipelineOpts = StgPipelineOpts
      { StgPipelineOpts -> [StgToDo]
    stgPipeline_phases      :: ![StgToDo]
      -- ^ Spec of what stg-to-stg passes to do
      , StgPipelineOpts -> Maybe DiagOpts
    stgPipeline_lint        :: !(Maybe DiagOpts)
      -- ^ Should we lint the STG at various stages of the pipeline?
      , StgPipelineOpts -> StgPprOpts
    stgPipeline_pprOpts     :: !StgPprOpts
      , StgPipelineOpts -> Platform
    stgPlatform             :: !Platform
      , StgPipelineOpts -> Bool
    stgPipeline_forBytecode :: !Bool
      }

    newtype StgM a = StgM { forall a. StgM a -> ReaderT Char IO a
    _unStgM :: ReaderT Char IO a }
      deriving ((forall a b. (a -> b) -> StgM a -> StgM b)
    -> (forall a b. a -> StgM b -> StgM a) -> Functor StgM
    forall a b. a -> StgM b -> StgM a
    forall a b. (a -> b) -> StgM a -> StgM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> StgM a -> StgM b
    fmap :: forall a b. (a -> b) -> StgM a -> StgM b
    $c<$ :: forall a b. a -> StgM b -> StgM a
    <$ :: forall a b. a -> StgM b -> StgM a
    Functor, Functor StgM
    Functor StgM =>
    (forall a. a -> StgM a)
    -> (forall a b. StgM (a -> b) -> StgM a -> StgM b)
    -> (forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c)
    -> (forall a b. StgM a -> StgM b -> StgM b)
    -> (forall a b. StgM a -> StgM b -> StgM a)
    -> Applicative StgM
    forall a. a -> StgM a
    forall a b. StgM a -> StgM b -> StgM a
    forall a b. StgM a -> StgM b -> StgM b
    forall a b. StgM (a -> b) -> StgM a -> StgM b
    forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c
    forall (f :: * -> *).
    Functor f =>
    (forall a. a -> f a)
    -> (forall a b. f (a -> b) -> f a -> f b)
    -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
    -> (forall a b. f a -> f b -> f b)
    -> (forall a b. f a -> f b -> f a)
    -> Applicative f
    $cpure :: forall a. a -> StgM a
    pure :: forall a. a -> StgM a
    $c<*> :: forall a b. StgM (a -> b) -> StgM a -> StgM b
    <*> :: forall a b. StgM (a -> b) -> StgM a -> StgM b
    $cliftA2 :: forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c
    liftA2 :: forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c
    $c*> :: forall a b. StgM a -> StgM b -> StgM b
    *> :: forall a b. StgM a -> StgM b -> StgM b
    $c<* :: forall a b. StgM a -> StgM b -> StgM a
    <* :: forall a b. StgM a -> StgM b -> StgM a
    Applicative, Applicative StgM
    Applicative StgM =>
    (forall a b. StgM a -> (a -> StgM b) -> StgM b)
    -> (forall a b. StgM a -> StgM b -> StgM b)
    -> (forall a. a -> StgM a)
    -> Monad StgM
    forall a. a -> StgM a
    forall a b. StgM a -> StgM b -> StgM b
    forall a b. StgM a -> (a -> StgM b) -> StgM b
    forall (m :: * -> *).
    Applicative m =>
    (forall a b. m a -> (a -> m b) -> m b)
    -> (forall a b. m a -> m b -> m b)
    -> (forall a. a -> m a)
    -> Monad m
    $c>>= :: forall a b. StgM a -> (a -> StgM b) -> StgM b
    >>= :: forall a b. StgM a -> (a -> StgM b) -> StgM b
    $c>> :: forall a b. StgM a -> StgM b -> StgM b
    >> :: forall a b. StgM a -> StgM b -> StgM b
    $creturn :: forall a. a -> StgM a
    return :: forall a. a -> StgM a
    Monad, Monad StgM
    Monad StgM => (forall a. IO a -> StgM a) -> MonadIO StgM
    forall a. IO a -> StgM a
    forall (m :: * -> *).
    Monad m =>
    (forall a. IO a -> m a) -> MonadIO m
    $cliftIO :: forall a. IO a -> StgM a
    liftIO :: forall a. IO a -> StgM a
    MonadIO)

    -- | Information to be exposed in interface files which is produced
    -- by the stg2stg passes.
    type StgCgInfos = NameEnv TagSig

    instance MonadUnique StgM where
      getUniqueSupplyM :: StgM UniqSupply
    getUniqueSupplyM = ReaderT Char IO UniqSupply -> StgM UniqSupply
    forall a. ReaderT Char IO a -> StgM a
    StgM (ReaderT Char IO UniqSupply -> StgM UniqSupply)
    -> ReaderT Char IO UniqSupply -> StgM UniqSupply
    forall a b. (a -> b) -> a -> b
    $ do { Char
    mask <- ReaderT Char IO Char
    forall (m :: * -> *) r. Monad m => ReaderT r m r
    ask
                                   ; IO UniqSupply -> ReaderT Char IO UniqSupply
    forall a. IO a -> ReaderT Char IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO UniqSupply -> ReaderT Char IO UniqSupply)
    -> IO UniqSupply -> ReaderT Char IO UniqSupply
    forall a b. (a -> b) -> a -> b
    $! Char -> IO UniqSupply
    mkSplitUniqSupply Char
    mask}
      getUniqueM :: StgM Unique
    getUniqueM = ReaderT Char IO Unique -> StgM Unique
    forall a. ReaderT Char IO a -> StgM a
    StgM (ReaderT Char IO Unique -> StgM Unique)
    -> ReaderT Char IO Unique -> StgM Unique
    forall a b. (a -> b) -> a -> b
    $ do { Char
    mask <- ReaderT Char IO Char
    forall (m :: * -> *) r. Monad m => ReaderT r m r
    ask
                             ; IO Unique -> ReaderT Char IO Unique
    forall a. IO a -> ReaderT Char IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Unique -> ReaderT Char IO Unique)
    -> IO Unique -> ReaderT Char IO Unique
    forall a b. (a -> b) -> a -> b
    $! Char -> IO Unique
    uniqFromMask Char
    mask}

    runStgM :: Char -> StgM a -> IO a
    runStgM :: forall a. Char -> StgM a -> IO a
    runStgM Char
    mask (StgM ReaderT Char IO a
    m) = ReaderT Char IO a -> Char -> IO a
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
    runReaderT ReaderT Char IO a
    m Char
    mask

    stg2stg :: Logger
            -> [Var]                     -- ^ extra vars in scope from GHCi
            -> StgPipelineOpts
            -> Module                    -- ^ module being compiled
            -> [StgTopBinding]           -- ^ input program
            -> IO ([CgStgTopBinding], StgCgInfos) -- output program
    stg2stg :: Logger
    -> [Id]
    -> StgPipelineOpts
    -> Module
    -> [StgTopBinding]
    -> IO ([CgStgTopBinding], StgCgInfos)
    stg2stg Logger
    logger [Id]
    extra_vars StgPipelineOpts
    opts Module
    this_mod [StgTopBinding]
    binds
      = do  { DumpFlag -> String -> [StgTopBinding] -> IO ()
    dump_when DumpFlag
    Opt_D_dump_stg_from_core String
    "Initial STG:" [StgTopBinding]
    binds
            ; Logger -> String -> IO ()
    showPass Logger
    logger String
    "Stg2Stg"
            -- Do the main business!
            ; [StgTopBinding]
    binds' <- Char -> StgM [StgTopBinding] -> IO [StgTopBinding]
    forall a. Char -> StgM a -> IO a
    runStgM Char
    'g' (StgM [StgTopBinding] -> IO [StgTopBinding])
    -> StgM [StgTopBinding] -> IO [StgTopBinding]
    forall a b. (a -> b) -> a -> b
    $
                ([StgTopBinding] -> StgToDo -> StgM [StgTopBinding])
    -> [StgTopBinding] -> [StgToDo] -> StgM [StgTopBinding]
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
    do_stg_pass Module
    this_mod) [StgTopBinding]
    binds (StgPipelineOpts -> [StgToDo]
    stgPipeline_phases StgPipelineOpts
    opts)

              -- Dependency sort the program as last thing. The program needs to be
              -- in dependency order for the SRT algorithm to work (see
              -- CmmBuildInfoTables, which also includes a detailed description of
              -- the algorithm), and we don't guarantee that the program is already
              -- sorted at this point. #16192 is for simplifier not preserving
              -- dependency order. We also don't guarantee that StgLiftLams will
              -- preserve the order or only create minimal recursive groups, so a
              -- sorting pass is necessary.
              -- This pass will also augment each closure with non-global free variables
              -- annotations (which is used by code generator to compute offsets into closures)
            ; let binds_sorted_with_fvs :: [CgStgTopBinding]
    binds_sorted_with_fvs = Module -> [StgTopBinding] -> [CgStgTopBinding]
    depSortWithAnnotStgPgm Module
    this_mod [StgTopBinding]
    binds'
            -- See Note [Tag inference for interactive contexts]
            ; StgPprOpts
    -> Bool
    -> Logger
    -> Module
    -> [CgStgTopBinding]
    -> IO ([CgStgTopBinding], StgCgInfos)
    inferTags (StgPipelineOpts -> StgPprOpts
    stgPipeline_pprOpts StgPipelineOpts
    opts) (StgPipelineOpts -> Bool
    stgPipeline_forBytecode StgPipelineOpts
    opts) Logger
    logger Module
    this_mod [CgStgTopBinding]
    binds_sorted_with_fvs
       }

      where
        stg_linter :: Bool -> String -> [StgTopBinding] -> IO ()
    stg_linter Bool
    unarised
          | Just DiagOpts
    diag_opts <- StgPipelineOpts -> Maybe DiagOpts
    stgPipeline_lint StgPipelineOpts
    opts
          = Platform
    -> Logger
    -> DiagOpts
    -> StgPprOpts
    -> [Id]
    -> Module
    -> Bool
    -> String
    -> [StgTopBinding]
    -> IO ()
    forall (a :: StgPass).
    (OutputablePass a, BinderP a ~ Id) =>
    Platform
    -> Logger
    -> DiagOpts
    -> StgPprOpts
    -> [Id]
    -> Module
    -> Bool
    -> String
    -> [GenStgTopBinding a]
    -> IO ()
    lintStgTopBindings
              (StgPipelineOpts -> Platform
    stgPlatform StgPipelineOpts
    opts) Logger
    logger
              DiagOpts
    diag_opts StgPprOpts
    ppr_opts
              [Id]
    extra_vars Module
    this_mod Bool
    unarised
          | Bool
    otherwise
          = \ String
    _whodunit [StgTopBinding]
    _binds -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        -------------------------------------------
        do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
        do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
    do_stg_pass Module
    this_mod [StgTopBinding]
    binds StgToDo
    to_do
          = case StgToDo
    to_do of
              StgToDo
    StgDoNothing ->
                [StgTopBinding] -> StgM [StgTopBinding]
    forall a. a -> StgM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [StgTopBinding]
    binds

              StgToDo
    StgStats ->
                Logger
    -> String -> SDoc -> StgM [StgTopBinding] -> StgM [StgTopBinding]
    forall a. Logger -> String -> SDoc -> a -> a
    logTraceMsg Logger
    logger String
    "STG stats" (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text ([StgTopBinding] -> String
    showStgStats [StgTopBinding]
    binds)) ([StgTopBinding] -> StgM [StgTopBinding]
    forall a. a -> StgM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [StgTopBinding]
    binds)

              StgToDo
    StgCSE -> do
                let binds' :: [StgTopBinding]
    binds' = {-# SCC "StgCse" #-} [StgTopBinding] -> [StgTopBinding]
    stgCse [StgTopBinding]
    binds
                String -> [StgTopBinding] -> StgM [StgTopBinding]
    end_pass String
    "StgCse" [StgTopBinding]
    binds'

              StgLiftLams StgLiftConfig
    cfg -> do
                UniqSupply
    us <- StgM UniqSupply
    forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
                --
                let binds' :: [StgTopBinding]
    binds' = {-# SCC "StgLiftLams" #-} Module
    -> StgLiftConfig
    -> UniqSupply
    -> [StgTopBinding]
    -> [StgTopBinding]
    stgLiftLams Module
    this_mod StgLiftConfig
    cfg UniqSupply
    us [StgTopBinding]
    binds
                String -> [StgTopBinding] -> StgM [StgTopBinding]
    end_pass String
    "StgLiftLams" [StgTopBinding]
    binds'

              StgToDo
    StgBcPrep -> do
                UniqSupply
    us <- StgM UniqSupply
    forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
                let binds' :: [StgTopBinding]
    binds' = {-# SCC "StgBcPrep" #-} UniqSupply -> [StgTopBinding] -> [StgTopBinding]
    bcPrep UniqSupply
    us [StgTopBinding]
    binds
                String -> [StgTopBinding] -> StgM [StgTopBinding]
    end_pass String
    "StgBcPrep" [StgTopBinding]
    binds'

              StgToDo
    StgUnarise -> do
                UniqSupply
    us <- StgM UniqSupply
    forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
                IO () -> StgM ()
    forall a. IO a -> StgM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (Bool -> String -> [StgTopBinding] -> IO ()
    stg_linter Bool
    False String
    "Pre-unarise" [StgTopBinding]
    binds)
                let binds' :: [StgTopBinding]
    binds' = {-# SCC "StgUnarise" #-} UniqSupply -> [StgTopBinding] -> [StgTopBinding]
    unarise UniqSupply
    us [StgTopBinding]
    binds
                IO () -> StgM ()
    forall a. IO a -> StgM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (DumpFlag -> String -> [StgTopBinding] -> IO ()
    dump_when DumpFlag
    Opt_D_dump_stg_unarised String
    "Unarised STG:" [StgTopBinding]
    binds')
                IO () -> StgM ()
    forall a. IO a -> StgM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (Bool -> String -> [StgTopBinding] -> IO ()
    stg_linter Bool
    True String
    "Unarise" [StgTopBinding]
    binds')
                [StgTopBinding] -> StgM [StgTopBinding]
    forall a. a -> StgM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [StgTopBinding]
    binds'

        ppr_opts :: StgPprOpts
    ppr_opts = StgPipelineOpts -> StgPprOpts
    stgPipeline_pprOpts StgPipelineOpts
    opts
        dump_when :: DumpFlag -> String -> [StgTopBinding] -> IO ()
    dump_when DumpFlag
    flag String
    header [StgTopBinding]
    binds
          = Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    putDumpFileMaybe Logger
    logger DumpFlag
    flag String
    header DumpFormat
    FormatSTG (StgPprOpts -> [StgTopBinding] -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> [GenStgTopBinding pass] -> SDoc
    pprStgTopBindings StgPprOpts
    ppr_opts [StgTopBinding]
    binds)

        end_pass :: String -> [StgTopBinding] -> StgM [StgTopBinding]
    end_pass String
    what [StgTopBinding]
    binds2
          = IO [StgTopBinding] -> StgM [StgTopBinding]
    forall a. IO a -> StgM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO [StgTopBinding] -> StgM [StgTopBinding])
    -> IO [StgTopBinding] -> StgM [StgTopBinding]
    forall a b. (a -> b) -> a -> b
    $ do -- report verbosely, if required
              Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    putDumpFileMaybe Logger
    logger DumpFlag
    Opt_D_verbose_stg2stg String
    what
                DumpFormat
    FormatSTG ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ((StgTopBinding -> SDoc) -> [StgTopBinding] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (StgPprOpts -> StgTopBinding -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgTopBinding pass -> SDoc
    pprStgTopBinding StgPprOpts
    ppr_opts) [StgTopBinding]
    binds2))
              Bool -> String -> [StgTopBinding] -> IO ()
    stg_linter Bool
    False String
    what [StgTopBinding]
    binds2
              [StgTopBinding] -> IO [StgTopBinding]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [StgTopBinding]
    binds2

    -- -----------------------------------------------------------------------------
    -- StgToDo:  abstraction of stg-to-stg passes to run.

    -- | Optional Stg-to-Stg passes.
    data StgToDo
      = StgCSE
      -- ^ Common subexpression elimination
      | StgLiftLams StgLiftConfig
      -- ^ Lambda lifting closure variables, trading stack/register allocation for
      -- heap allocation
      | StgStats
      | StgUnarise
      -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
      | StgBcPrep
      -- ^ Mandatory when compiling to bytecode
      | StgDoNothing
      -- ^ Useful for building up 'getStgToDo'
      deriving (Int -> StgToDo -> ShowS
    [StgToDo] -> ShowS
    StgToDo -> String
    (Int -> StgToDo -> ShowS)
    -> (StgToDo -> String) -> ([StgToDo] -> ShowS) -> Show StgToDo
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> StgToDo -> ShowS
    showsPrec :: Int -> StgToDo -> ShowS
    $cshow :: StgToDo -> String
    show :: StgToDo -> String
    $cshowList :: [StgToDo] -> ShowS
    showList :: [StgToDo] -> ShowS
    Show, ReadPrec [StgToDo]
    ReadPrec StgToDo
    Int -> ReadS StgToDo
    ReadS [StgToDo]
    (Int -> ReadS StgToDo)
    -> ReadS [StgToDo]
    -> ReadPrec StgToDo
    -> ReadPrec [StgToDo]
    -> Read StgToDo
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS StgToDo
    readsPrec :: Int -> ReadS StgToDo
    $creadList :: ReadS [StgToDo]
    readList :: ReadS [StgToDo]
    $creadPrec :: ReadPrec StgToDo
    readPrec :: ReadPrec StgToDo
    $creadListPrec :: ReadPrec [StgToDo]
    readListPrec :: ReadPrec [StgToDo]
    Read, StgToDo -> StgToDo -> Bool
    (StgToDo -> StgToDo -> Bool)
    -> (StgToDo -> StgToDo -> Bool) -> Eq StgToDo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: StgToDo -> StgToDo -> Bool
    == :: StgToDo -> StgToDo -> Bool
    $c/= :: StgToDo -> StgToDo -> Bool
    /= :: StgToDo -> StgToDo -> Bool
    Eq, Eq StgToDo
    Eq StgToDo =>
    (StgToDo -> StgToDo -> Ordering)
    -> (StgToDo -> StgToDo -> Bool)
    -> (StgToDo -> StgToDo -> Bool)
    -> (StgToDo -> StgToDo -> Bool)
    -> (StgToDo -> StgToDo -> Bool)
    -> (StgToDo -> StgToDo -> StgToDo)
    -> (StgToDo -> StgToDo -> StgToDo)
    -> Ord StgToDo
    StgToDo -> StgToDo -> Bool
    StgToDo -> StgToDo -> Ordering
    StgToDo -> StgToDo -> StgToDo
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: StgToDo -> StgToDo -> Ordering
    compare :: StgToDo -> StgToDo -> Ordering
    $c< :: StgToDo -> StgToDo -> Bool
    < :: StgToDo -> StgToDo -> Bool
    $c<= :: StgToDo -> StgToDo -> Bool
    <= :: StgToDo -> StgToDo -> Bool
    $c> :: StgToDo -> StgToDo -> Bool
    > :: StgToDo -> StgToDo -> Bool
    $c>= :: StgToDo -> StgToDo -> Bool
    >= :: StgToDo -> StgToDo -> Bool
    $cmax :: StgToDo -> StgToDo -> StgToDo
    max :: StgToDo -> StgToDo -> StgToDo
    $cmin :: StgToDo -> StgToDo -> StgToDo
    min :: StgToDo -> StgToDo -> StgToDo
    Ord)