X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;h=a09c8a6052bcca055e41f2ec7fdb08a1ca49a677;hp=afa1533efadf87715382b9b7a7b9178a4452afdd;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index afa1533..a09c8a6 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
 module CmmCPSZ (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -8,44 +6,87 @@ module CmmCPSZ (
 ) where
 
 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 PprCmmZ()
 import UniqSupply
-import ZipCfg hiding (zip, unzip)
-import ZipCfgCmm
-import ZipDataflow
 
 -----------------------------------------------------------------------------
 -- |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)
-  = do	{ showPass dflags "CPSZ"
-        ; u <- mkSplitUniqSupply 'p'
-        ; let txtops = initUs_ u $ mapM cpsTop tops
-        ; let pgm = Cmm $ runDFTx maxBound $ sequence txtops
-           --- XXX calling runDFTx is totally bogus
-	; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr pgm)
-        ; return pgm
-        }
+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	let dflags = hsc_dflags hsc_env
+        showPass dflags "CPSZ"
+        tops <- 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]
+~~~~~~~~~~~~~~~~~~~~~
+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 (DFTx 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'
-    in do us <- getUs
-          let g = runDFM us dualLiveLattice $ b_rewrite dualLivenessWithInsertion g''
-        --  let igraph = buildIGraph
-          return $ do g' <- g >>= return . map_nodes id spillAndReloadComments id
-                      return $ CmmProc h l args g'
+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
+       procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
+       let varSlots = emptyFM
+       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 emptyBlockSet) g
+       (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
+       g <- run $ addProcPointProtocols callPPs procPoints args 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)
+                    -- Remove redundant reloads (and any other redundant asst)
+       (_, g) <- trim g >>= run . 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)
+  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
+             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)