{-# 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]
, StgPipelineOpts -> Maybe DiagOpts
stgPipeline_lint :: !(Maybe DiagOpts)
, 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 -> 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
<$ :: forall a b. a -> StgM b -> StgM a
$c<$ :: forall a b. a -> StgM b -> StgM a
fmap :: forall a b. (a -> b) -> StgM a -> StgM b
$cfmap :: forall a b. (a -> b) -> StgM a -> StgM b
Functor, Functor 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
<* :: forall a b. StgM a -> StgM b -> StgM a
$c<* :: forall a b. StgM a -> StgM b -> StgM a
*> :: forall a b. StgM a -> StgM b -> StgM b
$c*> :: forall a b. StgM a -> StgM b -> StgM b
liftA2 :: forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c
$cliftA2 :: forall a b c. (a -> b -> c) -> StgM a -> StgM b -> StgM c
<*> :: forall a b. StgM (a -> b) -> StgM a -> StgM b
$c<*> :: forall a b. StgM (a -> b) -> StgM a -> StgM b
pure :: forall a. a -> StgM a
$cpure :: forall a. a -> StgM a
Applicative, Applicative 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
return :: forall a. a -> StgM a
$creturn :: forall a. a -> StgM a
>> :: forall a b. StgM a -> StgM b -> StgM b
$c>> :: forall a b. StgM a -> StgM b -> StgM b
>>= :: forall a b. StgM a -> (a -> StgM b) -> StgM b
$c>>= :: forall a b. StgM a -> (a -> StgM b) -> StgM b
Monad, Monad StgM
forall a. IO a -> StgM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> StgM a
$cliftIO :: forall a. IO a -> StgM a
MonadIO)
type StgCgInfos = NameEnv TagSig
instance MonadUnique StgM where
getUniqueSupplyM :: StgM UniqSupply
getUniqueSupplyM = forall a. ReaderT Char IO a -> StgM a
StgM forall a b. (a -> b) -> a -> b
$ do { Char
mask <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask}
getUniqueM :: StgM Unique
getUniqueM = forall a. ReaderT Char IO a -> StgM a
StgM forall a b. (a -> b) -> a -> b
$ do { Char
mask <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Char IO a
m Char
mask
stg2stg :: Logger
-> [Var]
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([CgStgTopBinding], StgCgInfos)
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"
; [StgTopBinding]
binds' <- forall a. Char -> StgM a -> IO a
runStgM Char
'g' forall a b. (a -> b) -> a -> b
$
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)
; let binds_sorted_with_fvs :: [CgStgTopBinding]
binds_sorted_with_fvs = Module -> [StgTopBinding] -> [CgStgTopBinding]
depSortWithAnnotStgPgm Module
this_mod [StgTopBinding]
binds'
; 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
= 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 -> 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 ->
forall (m :: * -> *) a. Monad m => a -> m a
return [StgTopBinding]
binds
StgToDo
StgStats ->
forall a. Logger -> String -> SDoc -> a -> a
logTraceMsg Logger
logger String
"STG stats" (forall doc. IsLine doc => String -> doc
text ([StgTopBinding] -> String
showStgStats [StgTopBinding]
binds)) (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 <- 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 <- 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 <- forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
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
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')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> String -> [StgTopBinding] -> IO ()
stg_linter Bool
True String
"Unarise" [StgTopBinding]
binds')
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 (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
= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_verbose_stg2stg String
what
DumpFormat
FormatSTG (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (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
forall (m :: * -> *) a. Monad m => a -> m a
return [StgTopBinding]
binds2
data StgToDo
= StgCSE
| StgLiftLams StgLiftConfig
| StgStats
| StgUnarise
| StgBcPrep
| StgDoNothing
deriving (Int -> StgToDo -> ShowS
[StgToDo] -> ShowS
StgToDo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StgToDo] -> ShowS
$cshowList :: [StgToDo] -> ShowS
show :: StgToDo -> String
$cshow :: StgToDo -> String
showsPrec :: Int -> StgToDo -> ShowS
$cshowsPrec :: Int -> StgToDo -> ShowS
Show, ReadPrec [StgToDo]
ReadPrec StgToDo
Int -> ReadS StgToDo
ReadS [StgToDo]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StgToDo]
$creadListPrec :: ReadPrec [StgToDo]
readPrec :: ReadPrec StgToDo
$creadPrec :: ReadPrec StgToDo
readList :: ReadS [StgToDo]
$creadList :: ReadS [StgToDo]
readsPrec :: Int -> ReadS StgToDo
$creadsPrec :: Int -> ReadS StgToDo
Read, StgToDo -> StgToDo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StgToDo -> StgToDo -> Bool
$c/= :: StgToDo -> StgToDo -> Bool
== :: StgToDo -> StgToDo -> Bool
$c== :: StgToDo -> StgToDo -> Bool
Eq, Eq 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
min :: StgToDo -> StgToDo -> StgToDo
$cmin :: StgToDo -> StgToDo -> StgToDo
max :: StgToDo -> StgToDo -> StgToDo
$cmax :: StgToDo -> StgToDo -> StgToDo
>= :: StgToDo -> StgToDo -> Bool
$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
compare :: StgToDo -> StgToDo -> Ordering
$ccompare :: StgToDo -> StgToDo -> Ordering
Ord)