{-# LANGUAGE BangPatterns #-}
module GHC.Cmm.Pipeline (
cmmPipeline
) where
import GHC.Prelude
import GHC.Cmm
import GHC.Cmm.Lint
import GHC.Cmm.Info.Build
import GHC.Cmm.CommonBlockElim
import GHC.Cmm.Switch.Implement
import GHC.Cmm.ProcPoint
import GHC.Cmm.ContFlowOpt
import GHC.Cmm.LayoutStack
import GHC.Cmm.Sink
import GHC.Cmm.Dataflow.Collections
import GHC.Types.Unique.Supply
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Driver.Env
import Control.Monad
import GHC.Utils.Outputable
import GHC.Platform
import Data.Either (partitionEithers)
cmmPipeline
:: HscEnv
-> ModuleSRTInfo
-> CmmGroup
-> IO (ModuleSRTInfo, CmmGroupSRTs)
cmmPipeline :: HscEnv
-> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, [CmmDeclSRTs])
cmmPipeline HscEnv
hsc_env ModuleSRTInfo
srtInfo CmmGroup
prog = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let forceRes :: (a, t a) -> ()
forceRes (a
info, t a
group) = a
info seq :: forall a b. a -> b -> b
`seq` forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
decl ()
r -> a
decl seq :: forall a b. a -> b -> b
`seq` ()
r) () t a
group
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger DynFlags
dflags (String -> SDoc
text String
"Cmm pipeline") forall {t :: * -> *} {a} {a}. Foldable t => (a, t a) -> ()
forceRes forall a b. (a -> b) -> a -> b
$ do
[Either (CAFEnv, CmmGroup) (Set CAFLabel, CmmDecl)]
tops <- {-# SCC "tops" #-} forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Logger
-> DynFlags
-> CmmDecl
-> IO (Either (CAFEnv, CmmGroup) (Set CAFLabel, CmmDecl))
cpsTop Logger
logger DynFlags
dflags) CmmGroup
prog
let ([(CAFEnv, CmmGroup)]
procs, [(Set CAFLabel, CmmDecl)]
data_) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (CAFEnv, CmmGroup) (Set CAFLabel, CmmDecl)]
tops
(ModuleSRTInfo
srtInfo, [CmmDeclSRTs]
cmms) <- {-# SCC "doSRTs" #-} DynFlags
-> ModuleSRTInfo
-> [(CAFEnv, CmmGroup)]
-> [(Set CAFLabel, CmmDecl)]
-> IO (ModuleSRTInfo, [CmmDeclSRTs])
doSRTs DynFlags
dflags ModuleSRTInfo
srtInfo [(CAFEnv, CmmGroup)]
procs [(Set CAFLabel, CmmDecl)]
data_
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_cps String
"Post CPS Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CmmDeclSRTs]
cmms)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleSRTInfo
srtInfo, [CmmDeclSRTs]
cmms)
cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
cpsTop :: Logger
-> DynFlags
-> CmmDecl
-> IO (Either (CAFEnv, CmmGroup) (Set CAFLabel, CmmDecl))
cpsTop Logger
_logger DynFlags
dflags p :: CmmDecl
p@(CmmData Section
_ GenCmmStatics 'False
statics) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Platform -> GenCmmStatics 'False -> Set CAFLabel
cafAnalData (DynFlags -> Platform
targetPlatform DynFlags
dflags) GenCmmStatics 'False
statics, CmmDecl
p))
cpsTop Logger
logger DynFlags
dflags CmmDecl
proc =
do
CmmProc CmmTopInfo
h CLabel
l [GlobalReg]
v CmmGraph
g <- {-# SCC "cmmCfgOpts(1)" #-}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
splitting_proc_points CmmDecl
proc
DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_cfg String
"Post control-flow optimisations" CmmGraph
g
let !TopInfo {stack_info :: CmmTopInfo -> CmmStackInfo
stack_info=StackInfo { arg_space :: CmmStackInfo -> Int
arg_space = Int
entry_off
, do_layout :: CmmStackInfo -> Bool
do_layout = Bool
do_layout }} = CmmTopInfo
h
CmmGraph
g <- {-# SCC "elimCommonBlocks" #-}
GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass GeneralFlag
Opt_CmmElimCommonBlocks CmmGraph -> CmmGraph
elimCommonBlocks CmmGraph
g
DumpFlag
Opt_D_dump_cmm_cbe String
"Post common block elimination"
CmmGraph
g <- {-# SCC "createSwitchPlans" #-}
forall a. UniqSM a -> IO a
runUniqSM forall a b. (a -> b) -> a -> b
$ Backend -> Platform -> CmmGraph -> UniqSM CmmGraph
cmmImplementSwitchPlans (DynFlags -> Backend
backend DynFlags
dflags) Platform
platform CmmGraph
g
DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_switch String
"Post switch plan" CmmGraph
g
let
call_pps :: ProcPointSet
call_pps :: ProcPointSet
call_pps = {-# SCC "callProcPoints" #-} CmmGraph -> ProcPointSet
callProcPoints CmmGraph
g
ProcPointSet
proc_points <-
if Bool
splitting_proc_points
then do
ProcPointSet
pp <- {-# SCC "minimalProcPointSet" #-} forall a. UniqSM a -> IO a
runUniqSM forall a b. (a -> b) -> a -> b
$
Platform -> ProcPointSet -> CmmGraph -> UniqSM ProcPointSet
minimalProcPointSet Platform
platform ProcPointSet
call_pps CmmGraph
g
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_proc String
"Proc points"
DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
l SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr ProcPointSet
pp SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGraph
g)
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
pp
else
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
call_pps
(CmmGraph
g, LabelMap StackMap
stackmaps) <-
{-# SCC "layoutStack" #-}
if Bool
do_layout
then forall a. UniqSM a -> IO a
runUniqSM forall a b. (a -> b) -> a -> b
$ DynFlags
-> ProcPointSet
-> Int
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
proc_points Int
entry_off CmmGraph
g
else forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph
g, forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_sp String
"Layout Stack" CmmGraph
g
CmmGraph
g <- {-# SCC "sink" #-}
GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass GeneralFlag
Opt_CmmSink (Platform -> CmmGraph -> CmmGraph
cmmSink Platform
platform) CmmGraph
g
DumpFlag
Opt_D_dump_cmm_sink String
"Sink assignments"
let cafEnv :: CAFEnv
cafEnv = {-# SCC "cafAnal" #-} Platform -> ProcPointSet -> CLabel -> CmmGraph -> CAFEnv
cafAnal Platform
platform ProcPointSet
call_pps CLabel
l CmmGraph
g
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_caf String
"CAFEnv" DumpFormat
FormatText (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CAFEnv
cafEnv)
CmmGroup
g <- if Bool
splitting_proc_points
then do
let pp_map :: LabelMap Status
pp_map = {-# SCC "procPointAnalysis" #-}
ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
proc_points CmmGraph
g
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_procmap String
"procpoint map"
DumpFormat
FormatCMM (forall a. Outputable a => a -> SDoc
ppr LabelMap Status
pp_map)
CmmGroup
g <- {-# SCC "splitAtProcPoints" #-} forall a. UniqSM a -> IO a
runUniqSM forall a b. (a -> b) -> a -> b
$
Platform
-> CLabel
-> ProcPointSet
-> ProcPointSet
-> LabelMap Status
-> CmmDecl
-> UniqSM CmmGroup
splitAtProcPoints Platform
platform CLabel
l ProcPointSet
call_pps ProcPointSet
proc_points LabelMap Status
pp_map
(forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
h CLabel
l [GlobalReg]
v CmmGraph
g)
DumpFlag -> String -> CmmGroup -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_split String
"Post splitting" CmmGroup
g
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroup
g
else
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables ProcPointSet
call_pps (forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
h CLabel
l [GlobalReg]
v CmmGraph
g)]
CmmGroup
g <- {-# SCC "setInfoTableStackMap" #-}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap Platform
platform LabelMap StackMap
stackmaps) CmmGroup
g
DumpFlag -> String -> CmmGroup -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_info String
"after setInfoTableStackMap" CmmGroup
g
CmmGroup
g <- {-# SCC "cmmCfgOpts(2)" #-}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if DynFlags -> Int
optLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
1
then forall a b. (a -> b) -> [a] -> [b]
map (Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
splitting_proc_points) CmmGroup
g
else CmmGroup
g
CmmGroup
g <- forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map CmmDecl -> CmmDecl
removeUnreachableBlocksProc CmmGroup
g)
DumpFlag -> String -> CmmGroup -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_cfg String
"Post control-flow optimisations" CmmGroup
g
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (CAFEnv
cafEnv, CmmGroup
g))
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
dump :: DumpFlag -> String -> CmmGraph -> IO ()
dump = Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph Logger
logger DynFlags
dflags
dumps :: DumpFlag -> String -> CmmGroup -> IO ()
dumps DumpFlag
flag String
name
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
flag String
name DumpFormat
FormatCMM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform)
condPass :: GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass GeneralFlag
flag CmmGraph -> CmmGraph
pass CmmGraph
g DumpFlag
dumpflag String
dumpname =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags
then do
CmmGraph
g <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CmmGraph -> CmmGraph
pass CmmGraph
g
DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
dumpflag String
dumpname CmmGraph
g
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGraph
g
else forall (m :: * -> *) a. Monad m => a -> m a
return CmmGraph
g
splitting_proc_points :: Bool
splitting_proc_points = DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
/= Backend
NCG
Bool -> Bool -> Bool
|| Bool -> Bool
not (Platform -> Bool
platformTablesNextToCode Platform
platform)
Bool -> Bool -> Bool
||
Bool
usingInconsistentPicReg
usingInconsistentPicReg :: Bool
usingInconsistentPicReg
= case (Platform -> Arch
platformArch Platform
platform, Platform -> OS
platformOS Platform
platform, DynFlags -> Bool
positionIndependent DynFlags
dflags)
of (Arch
ArchX86, OS
OSDarwin, Bool
pic) -> Bool
pic
(Arch, OS, Bool)
_ -> Bool
False
runUniqSM :: UniqSM a -> IO a
runUniqSM :: forall a. UniqSM a -> IO a
runUniqSM UniqSM a
m = do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'u'
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us UniqSM a
m)
dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph Logger
logger DynFlags
dflags DumpFlag
flag String
name CmmGraph
g = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ CmmGraph -> IO ()
do_lint CmmGraph
g
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
flag String
name DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGraph
g)
where
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
do_lint :: CmmGraph -> IO ()
do_lint CmmGraph
g = case Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph Platform
platform CmmGraph
g of
Just SDoc
err -> do { Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags SDoc
err
; Logger -> DynFlags -> Int -> IO ()
ghcExit Logger
logger DynFlags
dflags Int
1
}
Maybe SDoc
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith :: Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DynFlags
dflags DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc = do
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags)) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_cmm_verbose DynFlags
dflags)
forall a b. (a -> b) -> a -> b
$ Logger -> DumpAction
putDumpMsg Logger
logger DynFlags
dflags (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
alwaysQualify) DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_verbose_by_proc String
txt DumpFormat
fmt SDoc
sdoc