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
{ stgPipeline_phases :: ![StgToDo]
, stgPipeline_lint :: !(Maybe DiagOpts)
, stgPipeline_pprOpts :: !StgPprOpts
, stgPlatform :: !Platform
, stgPipeline_forBytecode :: !Bool
}
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
type StgCgInfos = NameEnv TagSig
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { mask <- ask
; liftIO $! mkSplitUniqSupply mask}
getUniqueM = StgM $ do { mask <- ask
; liftIO $! uniqFromMask mask}
runStgM :: Char -> StgM a -> IO a
runStgM mask (StgM m) = runReaderT m mask
stg2stg :: Logger
-> InteractiveContext
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([CgStgTopBinding], StgCgInfos)
stg2stg logger ictxt opts this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
; showPass logger "Stg2Stg"
; binds' <- runStgM 'g' $
foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts)
; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'
; inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs
}
where
stg_linter unarised
| Just diag_opts <- stgPipeline_lint opts
= lintStgTopBindings
(stgPlatform opts) logger
diag_opts ppr_opts
ictxt this_mod unarised
| otherwise
= \ _whodunnit _binds -> return ()
do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
do_stg_pass this_mod binds to_do
= case to_do of
StgDoNothing ->
return binds
StgStats ->
logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)
StgCSE -> do
let binds' = stgCse binds
end_pass "StgCse" binds'
StgLiftLams cfg -> do
us <- getUniqueSupplyM
let binds' = stgLiftLams this_mod cfg us binds
end_pass "StgLiftLams" binds'
StgBcPrep -> do
us <- getUniqueSupplyM
let binds' = bcPrep us binds
end_pass "StgBcPrep" binds'
StgUnarise -> do
us <- getUniqueSupplyM
liftIO (stg_linter False "Pre-unarise" binds)
let binds' = unarise us binds
liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
liftIO (stg_linter True "Unarise" binds')
return binds'
ppr_opts = stgPipeline_pprOpts opts
dump_when flag header binds
= putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)
end_pass what binds2
= liftIO $ do
putDumpFileMaybe logger Opt_D_verbose_stg2stg what
FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))
stg_linter False what binds2
return binds2
data StgToDo
= StgCSE
| StgLiftLams StgLiftConfig
| StgStats
| StgUnarise
| StgBcPrep
| StgDoNothing
deriving (Show, Read, Eq, Ord)