{-
(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.Var.Set
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.Stg.InferTags.TagSig ( StgCgInfos )

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)

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 { tag <- ReaderT Char IO Char
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
                               ; liftIO $! mkSplitUniqSupply tag}
  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 { tag <- ReaderT Char IO Char
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
                         ; liftIO $! uniqFromTag tag}

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,IdSet)], StgCgInfos) -- output program
stg2stg :: Logger
-> [Id]
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([(CgStgTopBinding, IdSet)], 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
        ; Bool -> String -> [StgTopBinding] -> IO ()
forall (a :: StgPass).
(BinderP a ~ Id, OutputablePass a) =>
Bool -> String -> [GenStgTopBinding a] -> IO ()
stg_linter Bool
False String
"StgFromCore" [StgTopBinding]
binds
        ; Logger -> String -> IO ()
showPass Logger
logger String
"Stg2Stg"
        -- Do the main business!
        ; 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, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds')
        -- See Note [Tag inference for interactive contexts]
        ; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs
        ; stg_linter False "StgCodeGen" cg_binds
        ; pure (zip cg_binds imp_fvs, cg_infos)
   }

  where
    stg_linter :: (BinderP a ~ Id, OutputablePass a) => Bool -> String -> [GenStgTopBinding a] -> IO ()
    stg_linter :: forall (a :: StgPass).
(BinderP a ~ Id, OutputablePass a) =>
Bool -> String -> [GenStgTopBinding a] -> IO ()
stg_linter Bool
unarised
      | Just DiagOpts
diag_opts <- StgPipelineOpts -> Maybe DiagOpts
stgPipeline_lint StgPipelineOpts
opts
      = Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> [Id]
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> 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 [GenStgTopBinding a]
_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
            us <- StgM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
            --
            let binds' = {-# SCC "StgLiftLams" #-} Module
-> StgLiftConfig
-> UniqSupply
-> [StgTopBinding]
-> [StgTopBinding]
stgLiftLams Module
this_mod StgLiftConfig
cfg UniqSupply
us [StgTopBinding]
binds
            end_pass "StgLiftLams" binds'

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

          StgToDo
StgUnarise -> do
            us <- StgM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
            liftIO (stg_linter False "Pre-unarise" binds)
            let binds' = {-# SCC "StgUnarise" #-} UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise UniqSupply
us [StgTopBinding]
binds
            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
            liftIO (stg_linter True "Unarise" binds')
            return 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 ()
forall (a :: StgPass).
(BinderP a ~ Id, OutputablePass a) =>
Bool -> String -> [GenStgTopBinding a] -> 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)