{-
(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.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.Runtime.Context ( InteractiveContext )

import GHC.Driver.Flags (DumpFlag(..))
import GHC.Utils.Error
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
        -> InteractiveContext
        -> StgPipelineOpts
        -> Module                    -- module being compiled
        -> [StgTopBinding]           -- input program
        -> IO ([CgStgTopBinding], StgCgInfos) -- output program
stg2stg :: Logger
-> InteractiveContext
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([CgStgTopBinding], StgCgInfos)
stg2stg Logger
logger InteractiveContext
ictxt 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
-> InteractiveContext
-> Module
-> Bool
-> String
-> [StgTopBinding]
-> IO ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> InteractiveContext
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings
          (StgPipelineOpts -> Platform
stgPlatform StgPipelineOpts
opts) Logger
logger
          DiagOpts
diag_opts StgPprOpts
ppr_opts
          InteractiveContext
ictxt Module
this_mod Bool
unarised
      | Bool
otherwise
      = \ String
_whodunnit [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
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
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)