module GHC.Cmm.Pipeline (
cmmPipeline
) where
import GHC.Prelude
import GHC.Driver.Flags
import GHC.Cmm
import GHC.Cmm.Config
import GHC.Cmm.ContFlowOpt
import GHC.Cmm.CommonBlockElim
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Info.Build
import GHC.Cmm.Lint
import GHC.Cmm.LayoutStack
import GHC.Cmm.ProcPoint
import GHC.Cmm.Sink
import GHC.Cmm.Switch.Implement
import GHC.Cmm.ThreadSanitizer
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DSM
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Misc ( partitionWith )
import GHC.Platform
import Control.Monad
import GHC.Utils.Monad (mapAccumLM)
cmmPipeline
:: Logger
-> CmmConfig
-> ModuleSRTInfo
-> CmmGroup
-> DUniqSupply
-> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply)
cmmPipeline :: Logger
-> CmmConfig
-> ModuleSRTInfo
-> CmmGroup
-> DUniqSupply
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
cmmPipeline Logger
logger CmmConfig
cmm_config ModuleSRTInfo
srtInfo CmmGroup
prog DUniqSupply
dus0 = do
let forceRes :: ((a, t a), a) -> ()
forceRes ((a
info, t a
group), a
us) = a
info a -> () -> ()
forall a b. a -> b -> b
`seq` a
us a -> () -> ()
forall a b. a -> b -> b
`seq` (a -> () -> ()) -> () -> t a -> ()
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> () -> ()
forall a b. a -> b -> b
seq () t a
group
let platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cmm_config
Logger
-> SDoc
-> (((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply) -> ())
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cmm pipeline") ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply) -> ()
forall {t :: * -> *} {a} {a} {a}. Foldable t => ((a, t a), a) -> ()
forceRes (IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply))
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
-> IO ((ModuleSRTInfo, [CmmDeclSRTs]), DUniqSupply)
forall a b. (a -> b) -> a -> b
$ do
(dus1, prog') <- {-# SCC "tops" #-} (DUniqSupply
-> CmmDecl
-> IO
(DUniqSupply,
Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl)))
-> DUniqSupply
-> CmmGroup
-> IO
(DUniqSupply,
[Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl)])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (Logger
-> Platform
-> CmmConfig
-> DUniqSupply
-> CmmDecl
-> IO
(DUniqSupply,
Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl))
cpsTop Logger
logger Platform
platform CmmConfig
cmm_config) DUniqSupply
dus0 CmmGroup
prog
let (procs, data_) = partitionWith id prog'
(srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus1 procs data_
dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
return ((srtInfo, cmms), dus)
cpsTop :: Logger -> Platform -> CmmConfig -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
cpsTop :: Logger
-> Platform
-> CmmConfig
-> DUniqSupply
-> CmmDecl
-> IO
(DUniqSupply,
Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl))
cpsTop Logger
_logger Platform
platform CmmConfig
_ DUniqSupply
dus (CmmData Section
section GenCmmStatics 'False
statics) =
(DUniqSupply,
Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl))
-> IO
(DUniqSupply,
Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DUniqSupply
dus, (Set CAFfyLabel, CmmDataDecl)
-> Either (CAFEnv, CmmGroup) (Set CAFfyLabel, CmmDataDecl)
forall a b. b -> Either a b
Right (Platform -> GenCmmStatics 'False -> Set CAFfyLabel
cafAnalData Platform
platform GenCmmStatics 'False
statics, Section -> GenCmmStatics 'False -> CmmDataDecl
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section GenCmmStatics 'False
statics))
cpsTop Logger
logger Platform
platform CmmConfig
cfg DUniqSupply
dus CmmDecl
proc =
do
CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
CmmDecl -> IO CmmDecl
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmDecl -> IO CmmDecl) -> CmmDecl -> IO CmmDecl
forall a b. (a -> b) -> a -> b
$ Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
splitting_proc_points CmmDecl
proc
dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g
let !TopInfo {stack_info=StackInfo { arg_space = entry_off
, do_layout = do_layout }} = h
g <- {-# SCC "elimCommonBlocks" #-}
condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g
Opt_D_dump_cmm_cbe "Post common block elimination"
(g, dus) <- if cmmDoCmmSwitchPlans cfg
then {-# SCC "createSwitchPlans" #-}
pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g
else pure (g, dus)
dump Opt_D_dump_cmm_switch "Post switch plan" g
g <- {-# SCC "annotateTSAN" #-}
if cmmOptThreadSanitizer cfg
then do
us <- mkSplitUniqSupply 'u'
return $ initUs_ us $
annotateTSAN platform g
else return g
dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g
let
call_pps :: ProcPointSet
call_pps = {-# SCC "callProcPoints" #-} CmmGraph -> ProcPointSet
callProcPoints CmmGraph
g
(proc_points, dus) <-
if splitting_proc_points
then do
let (pp, dus') = {-# SCC "minimalProcPointSet" #-} runUniqueDSM dus $
minimalProcPointSet platform call_pps g
dumpWith logger Opt_D_dump_cmm_proc "Proc points"
FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
return (pp, dus')
else
return (call_pps, dus)
((g, stackmaps), dus) <- pure $
{-# SCC "layoutStack" #-}
if do_layout
then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g
else ((g, mapEmpty), dus)
dump Opt_D_dump_cmm_sp "Layout Stack" g
(g, dus) <- {-# SCC "sink" #-}
if cmmOptSink cfg
then pure $ runUniqueDSM dus $ cmmSink cfg g
else return (g, dus)
dump Opt_D_dump_cmm_sink "Sink assignments" g
let cafEnv = {-# SCC "cafAnal" #-} Platform -> ProcPointSet -> CLabel -> CmmGraph -> CAFEnv
cafAnal Platform
platform ProcPointSet
call_pps CLabel
l CmmGraph
g
dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
(g, dus) <- if splitting_proc_points
then do
let pp_map = {-# SCC "procPointAnalysis" #-}
ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
proc_points CmmGraph
g
dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"
FormatCMM (ppr pp_map)
(g, dus) <- {-# SCC "splitAtProcPoints" #-} pure $ runUniqueDSM dus $
splitAtProcPoints platform l call_pps proc_points pp_map
(CmmProc h l v g)
dumps Opt_D_dump_cmm_split "Post splitting" g
return (g, dus)
else
return ([attachContInfoTables call_pps (CmmProc h l v g)], dus)
g <- {-# SCC "setInfoTableStackMap" #-}
return $ map (setInfoTableStackMap platform stackmaps) g
dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
g <- {-# SCC "cmmCfgOpts(2)" #-}
return $ if cmmOptControlFlow cfg
then map (cmmCfgOptsProc splitting_proc_points) g
else g
g <- return $ map (removeUnreachableBlocksProc platform) g
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations (2)" g
return (dus, Left (cafEnv, g))
where dump :: DumpFlag -> String -> CmmGraph -> IO ()
dump = Logger
-> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph Logger
logger Platform
platform (CmmConfig -> Bool
cmmDoLinting CmmConfig
cfg)
dumps :: DumpFlag -> String -> CmmGroup -> IO ()
dumps DumpFlag
flag String
name
= (CmmDecl -> IO ()) -> CmmGroup -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DumpFlag
flag String
name DumpFormat
FormatCMM (SDoc -> IO ()) -> (CmmDecl -> SDoc) -> CmmDecl -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform)
condPass :: Bool
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass Bool
do_opt CmmGraph -> CmmGraph
pass CmmGraph
g DumpFlag
dumpflag String
dumpname =
if Bool
do_opt
then do
g <- CmmGraph -> IO CmmGraph
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph -> IO CmmGraph) -> CmmGraph -> IO CmmGraph
forall a b. (a -> b) -> a -> b
$ CmmGraph -> CmmGraph
pass CmmGraph
g
dump dumpflag dumpname g
return g
else CmmGraph -> IO CmmGraph
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGraph
g
splitting_proc_points :: Bool
splitting_proc_points = CmmConfig -> Bool
cmmSplitProcPoints CmmConfig
cfg
dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph :: Logger
-> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph Logger
logger Platform
platform Bool
do_linting DumpFlag
flag String
name CmmGraph
g = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
do_linting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CmmGraph -> IO ()
do_lint CmmGraph
g
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DumpFlag
flag String
name DumpFormat
FormatCMM (Platform -> CmmGraph -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGraph
g)
where
do_lint :: CmmGraph -> IO ()
do_lint CmmGraph
g = case Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph Platform
platform CmmGraph
g of
Just SDoc
err -> do { Logger -> SDoc -> IO ()
fatalErrorMsg Logger
logger SDoc
err
; Logger -> ByteOff -> IO ()
ghcExit Logger
logger ByteOff
1
}
Maybe SDoc
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpWith Logger
logger DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc = do
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_cmm_verbose)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
alwaysQualify) DumpFlag
flag String
txt DumpFormat
fmt SDoc
sdoc
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_verbose_by_proc String
txt DumpFormat
fmt SDoc
sdoc