X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;h=d8c9560b49c9ca60804a26583f8d12895dd8552d;hp=b6b77f0f10b75ceb39510cb7807ab50c0b69716f;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=e06951a75a1f519e8f015880c363a8dedc08ff9c

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index b6b77f0..d8c9560 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -5,25 +5,19 @@ module CmmCPSZ (
   protoCmmCPSZ
 ) where
 
-import BlockId
 import Cmm
 import CmmCommonBlockElimZ
-import CmmContFlowOpt
 import CmmProcPointZ
 import CmmSpillReload
-import CmmTx
 import DFMonad
 import PprCmmZ()
-import ZipCfg hiding (zip, unzip)
 import ZipCfgCmmRep
 
 import DynFlags
 import ErrUtils
-import FiniteMap
 import HscTypes
 import Monad
 import Outputable
-import UniqSupply
 
 -----------------------------------------------------------------------------
 -- |Top level driver for the CPS pass
@@ -38,7 +32,7 @@ protoCmmCPSZ hsc_env (Cmm tops)
   | otherwise
   = do	let dflags = hsc_dflags hsc_env
         showPass dflags "CPSZ"
-        tops <- mapM (cpsTop hsc_env) tops
+        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
 
@@ -49,44 +43,48 @@ mutable reference cells in an 'HscEnv' and are
 global to one compiler session.
 -}
 
-cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
-cpsTop _ p@(CmmData {}) = return p
+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 <- return $ map_nodes id NotSpillOrReload id g
-               -- Change types of middle nodes to allow spill/reload
-       g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+       g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
                              (dualLivenessWithInsertion callPPs) g
-       (varSlots, g) <- trim g >>= return . elimSpillAndReload emptyFM
-       procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ 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 <- return $ map_nodes id NotSpillOrReload id g
-               -- Change types of middle nodes to allow spill/reload
        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     <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-                                        (removeDeadAssignmentsAndReloads procPoints)
+       g     <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+                                        (removeDeadAssignmentsAndReloads procPoints) g
                     -- Remove redundant reloads (and any other redundant asst)
-       (_, g) <- trim g >>= return . elimSpillAndReload varSlots
-       gs    <- run $ splitAtProcPoints args l procPoints g
-       gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
-       g     <- return $ elimCommonBlocks g
-       dump Opt_D_dump_cmmz "Post common block elimination" g
-       return $ CmmProc h l args (runTx cmmCfgOptsZ g)
+       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 (graphOfLGraph g) >>= lGraphOfGraph
+             g <- run $ pass g
              dump flag ("Post " ++ txt) $ g
-             return $ graphOfLGraph g
-        trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
-        trim (Graph tail blocks) =
-          do entry <- liftM BlockId $ run $ getUniqueM
-             return $ LGraph entry (insertBlock (Block entry tail) blocks)
+             return g