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 Cmm
   9 import CmmCommonBlockElimZ
  10 import CmmContFlowOpt
  11 import CmmProcPointZ
  12 import CmmSpillReload
  13 import CmmTx
  14 import DFMonad
  15 import PprCmmZ()
  16 import ZipCfg hiding (zip, unzip)
  17 import ZipCfgCmmRep
  18
  19 import DynFlags
  20 import ErrUtils
  21 import FiniteMap
  22 import HscTypes
  23 import Monad
  24 import Outputable
  25 import UniqSupply
  26
  27 -----------------------------------------------------------------------------
  28 -- |Top level driver for the CPS pass
  29 -----------------------------------------------------------------------------
  30 protoCmmCPSZ :: HscEnv -- Compilation env including
  31                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  32              -> CmmZ     -- Input C-- with Proceedures
  33              -> IO CmmZ  -- Output CPS transformed C--
  34 protoCmmCPSZ hsc_env (Cmm tops)
  35   | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
  36   = return (Cmm tops)                -- Only if -frun-cps
  37   | otherwise
  38   = do  let dflags = hsc_dflags hsc_env
  39         showPass dflags "CPSZ"
  40         tops <- mapM (cpsTop hsc_env) tops
  41         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
  42         return $ Cmm tops
  43
  44 {- [Note global fuel]
  45 ~~~~~~~~~~~~~~~~~~~~~
  46 The identity and the last pass are stored in
  47 mutable reference cells in an 'HscEnv' and are
  48 global to one compiler session.
  49 -}
  50
  51 cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
  52 cpsTop _ p@(CmmData {}) = return p
  53 cpsTop hsc_env (CmmProc h l args g) =
  54     do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  55        let callPPs = callProcPoints g
  56        procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
  57        let varSlots = emptyFM
  58        g <- return $ map_nodes id NotSpillOrReload id g
  59                -- Change types of middle nodes to allow spill/reload
  60        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  61                              (dualLivenessWithInsertion emptyBlockSet) g
  62        (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
  63        g <- run $ addProcPointProtocols callPPs procPoints args 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 >>= run . 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)