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 CmmProcPointZ
  11 import CmmSpillReload
  12 import DFMonad
  13 import PprCmmZ()
  14 import ZipCfgCmmRep
  15
  16 import DynFlags
  17 import ErrUtils
  18 import HscTypes
  19 import Monad
  20 import Outputable
  21
  22 -----------------------------------------------------------------------------
  23 -- |Top level driver for the CPS pass
  24 -----------------------------------------------------------------------------
  25 protoCmmCPSZ :: HscEnv -- Compilation env including
  26                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  27              -> CmmZ     -- Input C-- with Proceedures
  28              -> IO CmmZ  -- Output CPS transformed C--
  29 protoCmmCPSZ hsc_env (Cmm tops)
  30   | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
  31   = return (Cmm tops)                -- Only if -frun-cps
  32   | otherwise
  33   = do  let dflags = hsc_dflags hsc_env
  34         showPass dflags "CPSZ"
  35         tops <- liftM concat $ mapM (cpsTop hsc_env) tops
  36         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
  37         return $ Cmm tops
  38
  39 {- [Note global fuel]
  40 ~~~~~~~~~~~~~~~~~~~~~
  41 The identity and the last pass are stored in
  42 mutable reference cells in an 'HscEnv' and are
  43 global to one compiler session.
  44 -}
  45
  46 cpsTop :: HscEnv -> CmmTopZ -> IO [CmmTopZ]
  47 cpsTop _ p@(CmmData {}) = return [p]
  48 cpsTop hsc_env (CmmProc h l args g) =
  49     do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  50        let callPPs = callProcPoints g
  51        g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  52                              (dualLivenessWithInsertion callPPs) g
  53        dump Opt_D_dump_cmmz "Pre common block elimination" g
  54        g <- return $ elimCommonBlocks g
  55        dump Opt_D_dump_cmmz "Post common block elimination" g
  56        procPoints <- run $ minimalProcPointSet callPPs g
  57        print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
  58        g <- run $ addProcPointProtocols callPPs procPoints g
  59        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  60        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  61                              (dualLivenessWithInsertion procPoints) g
  62                     -- Insert spills at defns; reloads at return points
  63        g     <- run $ insertLateReloads' g -- Duplicate reloads just before uses
  64        dump Opt_D_dump_cmmz "Post late reloads" g
  65        g     <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  66                                         (removeDeadAssignmentsAndReloads procPoints) g
  67                     -- Remove redundant reloads (and any other redundant asst)
  68        slotEnv <- run $ liveSlotAnal g
  69        print $ "live slot analysis results: " ++ (showSDoc $ ppr slotEnv)
  70        cafEnv <- run $ cafAnal g
  71        print $ "live CAF analysis results: " ++ (showSDoc $ ppr cafEnv)
  72        slotIGraph <- return $ igraph areaBuilder slotEnv g
  73        print $ "slot IGraph: " ++ (showSDoc $ ppr slotIGraph)
  74        print $ "graph before procPointMap: " ++ (showSDoc $ ppr g)
  75        procPointMap <- run $ procPointAnalysis procPoints g
  76        let areaMap = layout procPoints slotEnv g
  77        g  <- run $ manifestSP procPoints procPointMap areaMap g
  78        procPointMap <- run $ procPointAnalysis procPoints g
  79        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap slotEnv areaMap
  80                                      (CmmProc h l args g)
  81        return gs
  82        --return $ [CmmProc h l args (runTx cmmCfgOptsZ g)]
  83   where dflags = hsc_dflags hsc_env
  84         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
  85         run = runFuelIO (hsc_OptFuel hsc_env)
  86         dual_rewrite flag txt pass g =
  87           do dump flag ("Pre " ++ txt)  g
  88              g <- run $ pass g
  89              dump flag ("Post " ++ txt) $ g
  90              return g