) where
import Cmm
-import CmmContFlowOpt
+import CmmCommonBlockElimZ
import CmmProcPointZ
import CmmSpillReload
-import CmmTx
import DFMonad
import PprCmmZ()
-import ZipCfg hiding (zip, unzip)
import ZipCfgCmmRep
-import ZipDataflow0
import DynFlags
import ErrUtils
+import HscTypes
+import Monad
import Outputable
-import UniqSupply
-
-import Data.IORef
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
-protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
- -> CmmZ -- ^ Input C-- with Proceedures
- -> IO CmmZ -- ^ Output CPS transformed C--
-protoCmmCPSZ dflags (Cmm tops)
- | not (dopt Opt_RunCPSZ dflags)
+protoCmmCPSZ :: HscEnv -- Compilation env including
+ -- dynamic flags: -dcmm-lint -ddump-cps-cmm
+ -> CmmZ -- Input C-- with Proceedures
+ -> IO CmmZ -- Output CPS transformed C--
+protoCmmCPSZ hsc_env (Cmm tops)
+ | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
= return (Cmm tops) -- Only if -frun-cps
| otherwise
- = do { showPass dflags "CPSZ"
- ; u <- mkSplitUniqSupply 'p'
- ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
- ; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel]
- ; let txtops = initUs_ u $ mapM cpsTop tops
- ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
- ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
- ; return $ Cmm tops
- }
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags "CPSZ"
+ tops <- liftM concat $ mapM (cpsTop hsc_env) tops
+ dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
+ return $ Cmm tops
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
-In a correct world, the identity and the last pass would be stored in
-mutable reference cells associated with an 'HscEnv' and would be
-global to one compiler session. Unfortunately the 'HscEnv' is not
-plumbed sufficiently close to this function; only the DynFlags are
-plumbed here. One day the plumbing will be extended, in which case
-this pass will use the global 'pass_ref' and 'fuel_ref' instead of the
-bogus facsimiles in place here.
+The identity and the last pass are stored in
+mutable reference cells in an 'HscEnv' and are
+global to one compiler session.
-}
-cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
-cpsTop p@(CmmData {}) = return (return p)
-cpsTop (CmmProc h l args g) =
- let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
- g' = addProcPointProtocols procPoints args g
- g'' = map_nodes id NotSpillOrReload id g'
- -- Change types of middle nodes to allow spill/reload
- in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
- ; entry <- getUniqueUs >>= return . BlockId
- ; return $
- do { g <- return g''
- ; g <- dual_rewrite u1 dualLivenessWithInsertion g
- -- Insert spills at defns; reloads at return points
- ; g <- insertLateReloads' u2 (extend g)
- -- Duplicate reloads just before uses
- ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
- -- Remove redundant reloads (and any other redundant asst)
- ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
- }
- }
- where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
- extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
- trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
- trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)
+cpsTop :: HscEnv -> CmmTopZ -> IO [CmmTopZ]
+cpsTop _ p@(CmmData {}) = return [p]
+cpsTop hsc_env (CmmProc h l args g) =
+ do dump Opt_D_dump_cmmz "Pre Proc Points Added" g
+ let callPPs = callProcPoints g
+ g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ (dualLivenessWithInsertion callPPs) g
+ dump Opt_D_dump_cmmz "Pre common block elimination" g
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz "Post common block elimination" g
+ procPoints <- run $ minimalProcPointSet callPPs g
+ print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
+ g <- run $ addProcPointProtocols callPPs procPoints g
+ dump Opt_D_dump_cmmz "Post Proc Points Added" g
+ g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ (dualLivenessWithInsertion procPoints) g
+ -- Insert spills at defns; reloads at return points
+ g <- run $ insertLateReloads' g -- Duplicate reloads just before uses
+ dump Opt_D_dump_cmmz "Post late reloads" g
+ g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ (removeDeadAssignmentsAndReloads procPoints) g
+ -- Remove redundant reloads (and any other redundant asst)
+ slotEnv <- run $ liveSlotAnal g
+ print $ "live slot analysis results: " ++ (showSDoc $ ppr slotEnv)
+ cafEnv <- run $ cafAnal g
+ print $ "live CAF analysis results: " ++ (showSDoc $ ppr cafEnv)
+ slotIGraph <- return $ igraph areaBuilder slotEnv g
+ print $ "slot IGraph: " ++ (showSDoc $ ppr slotIGraph)
+ print $ "graph before procPointMap: " ++ (showSDoc $ ppr g)
+ procPointMap <- run $ procPointAnalysis procPoints g
+ let areaMap = layout procPoints slotEnv g
+ g <- run $ manifestSP procPoints procPointMap areaMap g
+ procPointMap <- run $ procPointAnalysis procPoints g
+ gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap slotEnv areaMap
+ (CmmProc h l args g)
+ return gs
+ --return $ [CmmProc h l args (runTx cmmCfgOptsZ g)]
+ where dflags = hsc_dflags hsc_env
+ dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+ run = runFuelIO (hsc_OptFuel hsc_env)
+ dual_rewrite flag txt pass g =
+ do dump flag ("Pre " ++ txt) g
+ g <- run $ pass g
+ dump flag ("Post " ++ txt) $ g
+ return g