-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
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
protoCmmCPSZ dflags (Cmm tops)
= 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 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'
+ in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
+ ; entry <- getUniqueUs >>= return . BlockId
+ ; return $
+ do { g <- return g''
+ ; g <- dual_rewrite u1 dualLivenessWithInsertion g
+ ; g <- insertLateReloads' u2 (extend g)
+ ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
+ ; 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)