compiler/cmm/CmmCPSZ.hs

   1 module CmmCPSZ (
   2   -- | Converts C-- with full proceedures and parameters
   3   -- to a CPS transformed C-- with the stack made manifest.
   4   -- Well, sort of.
   5   protoCmmCPSZ
   6 ) where
   7
   8 import BlockId
   9 import Cmm
  10 import CmmCommonBlockElimZ
  11 import CmmContFlowOpt
  12 import CmmProcPointZ
  13 import CmmSpillReload
  14 import CmmTx
  15 import DFMonad
  16 import PprCmmZ()
  17 import ZipCfg hiding (zip, unzip)
  18 import ZipCfgCmmRep
  19
  20 import DynFlags
  21 import ErrUtils
  22 import FiniteMap
  23 import HscTypes
  24 import Monad
  25 import Outputable
  26 import UniqSupply
  27
  28 -----------------------------------------------------------------------------
  29 -- |Top level driver for the CPS pass
  30 -----------------------------------------------------------------------------
  31 protoCmmCPSZ :: HscEnv -- Compilation env including
  32                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  33              -> CmmZ     -- Input C-- with Proceedures
  34              -> IO CmmZ  -- Output CPS transformed C--
  35 protoCmmCPSZ hsc_env (Cmm tops)
  36   | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
  37   = return (Cmm tops)                -- Only if -frun-cps
  38   | otherwise
  39   = do  let dflags = hsc_dflags hsc_env
  40         showPass dflags "CPSZ"
  41         tops <- mapM (cpsTop hsc_env) tops
  42         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
  43         return $ Cmm tops
  44
  45 {- [Note global fuel]
  46 ~~~~~~~~~~~~~~~~~~~~~
  47 The identity and the last pass are stored in
  48 mutable reference cells in an 'HscEnv' and are
  49 global to one compiler session.
  50 -}
  51
  52 cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
  53 cpsTop _ p@(CmmData {}) = return p
  54 cpsTop hsc_env (CmmProc h l args g) =
  55     do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  56        let callPPs = callProcPoints g
  57        g <- return $ map_nodes id NotSpillOrReload id g
  58                -- Change types of middle nodes to allow spill/reload
  59        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  60                              (dualLivenessWithInsertion callPPs) g
  61        (varSlots, g) <- trim g >>= return . elimSpillAndReload emptyFM
  62        procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
  63        g <- run $ addProcPointProtocols callPPs procPoints g
  64        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  65        g <- return $ map_nodes id NotSpillOrReload id g
  66                -- Change types of middle nodes to allow spill/reload
  67        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  68                              (dualLivenessWithInsertion procPoints) g
  69                     -- Insert spills at defns; reloads at return points
  70        g     <- run $ insertLateReloads' g -- Duplicate reloads just before uses
  71        dump Opt_D_dump_cmmz "Post late reloads" g
  72        g     <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  73                                         (removeDeadAssignmentsAndReloads procPoints)
  74                     -- Remove redundant reloads (and any other redundant asst)
  75        (_, g) <- trim g >>= return . elimSpillAndReload varSlots
  76        gs    <- run $ splitAtProcPoints args l procPoints g
  77        gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
  78        g     <- return $ elimCommonBlocks g
  79        dump Opt_D_dump_cmmz "Post common block elimination" g
  80        return $ CmmProc h l args (runTx cmmCfgOptsZ g)
  81   where dflags = hsc_dflags hsc_env
  82         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
  83         run = runFuelIO (hsc_OptFuel hsc_env)
  84         dual_rewrite flag txt pass g =
  85           do dump flag ("Pre " ++ txt)  g
  86              g <- run $ pass (graphOfLGraph g) >>= lGraphOfGraph
  87              dump flag ("Post " ++ txt) $ g
  88              return $ graphOfLGraph g
  89         trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
  90         trim (Graph tail blocks) =
  91           do entry <- liftM BlockId $ run $ getUniqueM
  92              return $ LGraph entry (insertBlock (Block entry tail) blocks)