X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;h=3d8ac22f5342eed0cee35ca8bab95f47b761d30b;hb=5699ec476d64d48b7fcf6812238406e1eea91bef;hp=4dff9bc1d472a609a04a9901106419aa9b23626f;hpb=684fde094dc5b064b49dbef191ca07cb9a018e45;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 4dff9bc..3d8ac22 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -1,4 +1,3 @@
-
 module CmmCPSZ (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -12,14 +11,17 @@ import CmmProcPointZ
 import CmmSpillReload
 import CmmTx
 import DFMonad
+import PprCmmZ()
+import ZipCfg hiding (zip, unzip)
+import ZipCfgCmmRep
+import ZipDataflow0
+
 import DynFlags
 import ErrUtils
 import Outputable
-import PprCmmZ()
 import UniqSupply
-import ZipCfg hiding (zip, unzip)
-import ZipCfgCmmRep
-import ZipDataflow
+
+import Data.IORef
 
 -----------------------------------------------------------------------------
 -- |Top level driver for the CPS pass
@@ -28,27 +30,51 @@ 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) 
+  = 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
-        ; 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
+        ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
+	; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
+        ; return $ Cmm tops
         }
 
-cpsTop :: CmmTopZ -> UniqSM (DFTx CmmTopZ)
-cpsTop p@(CmmData {}) = return $ return p
+{- [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.
+-}
+
+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'
-    in do g <- dual_rewrite dualLivenessWithInsertion g''
-          g <- return (g >>= insertLateReloads)
-          u <- getUs
-          let g' = g >>= (initUs_ u . dual_rewrite removeDeadAssignmentsAndReloads)
-          return $ do g <- g' >>= return . map_nodes id spillAndReloadComments id
-                      return $ CmmProc h l args g
-  where dual_rewrite pass g =
-            do us <- getUs
-               return $ runDFM us dualLiveLattice $ b_rewrite pass 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)