compiler/cmm/CmmCPSZ.hs

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