module CmmPipeline (
cmmPipeline
) where
import Cmm
import CmmLint
import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
import CmmSink
import Hoopl
import UniqSupply
import DynFlags
import ErrUtils
import HscTypes
import Control.Monad
import Outputable
cmmPipeline :: HscEnv
-> TopSRT
-> CmmGroup
-> IO (TopSRT, CmmGroup)
cmmPipeline hsc_env topSRT prog =
do let dflags = hsc_dflags hsc_env
showPass dflags "CPSZ"
tops <- mapM (cpsTop hsc_env) prog
(topSRT, cmms) <- doSRTs topSRT tops
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
return (topSRT, cmms)
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
g <- return $ cmmCfgOpts g
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
let callPPs = callProcPoints g
procPoints <- runUniqSM $
minimalProcPointSet (targetPlatform dflags) callPPs g
(g, stackmaps) <-
runUniqSM $ cmmLayoutStack procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- if optLevel dflags >= 99
then do g <- return (cmmSink g)
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
g <- return (cmmPeepholeInline g)
dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
return g
else return g
procPointMap <- runUniqSM $
procPointAnalysis procPoints g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- runUniqSM $
splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
let cafEnv = cafAnal g
gs <-
return $ map (setInfoTableStackMap stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
gs <- return $ map cmmCfgOptsProc gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
return (cafEnv, gs)
where dflags = hsc_dflags hsc_env
dump = dumpGraph dflags
dumps flag name
= mapM_ (dumpWith dflags flag name)
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
us <- mkSplitUniqSupply 'u'
return (initUs_ us m)
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
when (dopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name g
where
do_lint g = case cmmLintGraph g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
}
Nothing -> return ()
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
dumpIfSet_dyn dflags flag txt (ppr g)
when (not (dopt flag dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)