compiler/cmm/CmmCPSZ.hs

   1
   2 module CmmCPSZ (
   3   -- | Converts C-- with full proceedures and parameters
   4   -- to a CPS transformed C-- with the stack made manifest.
   5   -- Well, sort of.
   6   protoCmmCPSZ
   7 ) where
   8
   9 import Cmm
  10 import CmmContFlowOpt
  11 import CmmProcPointZ
  12 import CmmSpillReload
  13 import CmmTx
  14 import DFMonad
  15 import DynFlags
  16 import ErrUtils
  17 import Outputable
  18 import PprCmmZ()
  19 import UniqSupply
  20 import ZipCfg hiding (zip, unzip)
  21 import ZipCfgCmmRep
  22 import ZipDataflow
  23
  24 -----------------------------------------------------------------------------
  25 -- |Top level driver for the CPS pass
  26 -----------------------------------------------------------------------------
  27 protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  28        -> CmmZ     -- ^ Input C-- with Proceedures
  29        -> IO CmmZ  -- ^ Output CPS transformed C--
  30 protoCmmCPSZ dflags (Cmm tops)
  31   = do  { showPass dflags "CPSZ"
  32         ; u <- mkSplitUniqSupply 'p'
  33         ; let txtops = initUs_ u $ mapM cpsTop tops
  34         ; let pgm = Cmm $ runDFTx maxBound $ sequence txtops
  35            --- XXX calling runDFTx is totally bogus
  36         ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr pgm)
  37         ; return pgm
  38         }
  39
  40 cpsTop :: CmmTopZ -> UniqSM (DFTx CmmTopZ)
  41 cpsTop p@(CmmData {}) = return $ return p
  42 cpsTop (CmmProc h l args g) =
  43     let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
  44         g' = addProcPointProtocols procPoints args g
  45         g'' = map_nodes id NotSpillOrReload id g'
  46     in do us <- getUs
  47           let g = runDFM us dualLiveLattice $ b_rewrite dualLivenessWithInsertion g''
  48         --  let igraph = buildIGraph
  49           return $ do g' <- g >>= return . map_nodes id spillAndReloadComments id
  50                       return $ CmmProc h l args g'