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 CLabel
   9 import Cmm
  10 import CmmBuildInfoTables
  11 import CmmCommonBlockElimZ
  12 import CmmProcPointZ
  13 import CmmSpillReload
  14 import CmmStackLayout
  15 import DFMonad
  16 import PprCmmZ()
  17 import ZipCfgCmmRep
  18
  19 import DynFlags
  20 import ErrUtils
  21 import FiniteMap
  22 import HscTypes
  23 import Maybe
  24 import Monad
  25 import Outputable
  26 import StaticFlags
  27
  28 -----------------------------------------------------------------------------
  29 -- |Top level driver for the CPS pass
  30 -----------------------------------------------------------------------------
  31 -- There are two complications here:
  32 -- 1. We need to compile the procedures in two stages because we need
  33 --    an analysis of the procedures to tell us what CAFs they use.
  34 --    The first stage returns a map from procedure labels to CAFs,
  35 --    along with a closure that will compute SRTs and attach them to
  36 --    the compiled procedures.
  37 --    The second stage is to combine the CAF information into a top-level
  38 --    CAF environment mapping non-static closures to the CAFs they keep live,
  39 --    then pass that environment to the closures returned in the first
  40 --    stage of compilation.
  41 -- 2. We need to thread the module's SRT around when the SRT tables
  42 --    are computed for each procedure.
  43 --    The SRT needs to be threaded because it is grown lazily.
  44 protoCmmCPSZ :: HscEnv -- Compilation env including
  45                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  46              -> (TopSRT, [CmmZ])  -- SRT table and
  47              -> CmmZ              -- Input C-- with Procedures
  48              -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
  49 protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
  50   | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
  51   = return (topSRT, Cmm tops : rst)                -- Only if -frun-cps
  52   | otherwise
  53   = do  let dflags = hsc_dflags hsc_env
  54         showPass dflags "CPSZ"
  55         (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
  56         let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
  57         (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
  58         let cmms = Cmm (reverse (concat tops))
  59         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
  60         return (topSRT, cmms : rst)
  61
  62 {- [Note global fuel]
  63 ~~~~~~~~~~~~~~~~~~~~~
  64 The identity and the last pass are stored in
  65 mutable reference cells in an 'HscEnv' and are
  66 global to one compiler session.
  67 -}
  68
  69 cpsTop :: HscEnv -> CmmTopZ ->
  70           IO ([(CLabel, CAFSet)],
  71               (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]])))
  72 cpsTop _ p@(CmmData {}) =
  73   return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops)))
  74 cpsTop hsc_env (CmmProc h l args g) =
  75     do
  76        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  77        let callPPs = callProcPoints g
  78        g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  79                              (dualLivenessWithInsertion callPPs) g
  80        g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  81                          (removeDeadAssignmentsAndReloads callPPs) g
  82        dump Opt_D_dump_cmmz "Pre common block elimination" g
  83        g <- return $ elimCommonBlocks g
  84        dump Opt_D_dump_cmmz "Post common block elimination" g
  85        procPoints <- run $ minimalProcPointSet callPPs g
  86        -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
  87        g <- run $ addProcPointProtocols callPPs procPoints g
  88        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  89        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  90                              (dualLivenessWithInsertion procPoints) g
  91                     -- Insert spills at defns; reloads at return points
  92        g     <- run $ insertLateReloads g -- Duplicate reloads just before uses
  93        dump Opt_D_dump_cmmz "Post late reloads" g
  94        g     <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  95                                         (removeDeadAssignmentsAndReloads procPoints) g
  96                     -- Remove redundant reloads (and any other redundant asst)
  97        -- Debugging: stubbing slots on death can cause crashes early
  98        g <-  if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
  99        mbpprTrace "graph before procPointMap: " (ppr g) $ return ()
 100        procPointMap <- run $ procPointAnalysis procPoints g
 101        slotEnv <- run $ liveSlotAnal g
 102        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 103        cafEnv <- run $ cafAnal g
 104        (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
 105        mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
 106        let areaMap = layout procPoints slotEnv g
 107        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 108        g  <- run $ manifestSP procPoints procPointMap areaMap g
 109        dump Opt_D_dump_cmmz "after manifestSP" g
 110        -- UGH... manifestSP can require updates to the procPointMap.
 111        -- We can probably do something quicker here for the update...
 112        procPointMap  <- run $ procPointAnalysis procPoints g
 113        gs <- pprTrace "procPointMap" (ppr procPointMap) $
 114                run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
 115                                        (CmmProc h l args g)
 116        mapM (dump Opt_D_dump_cmmz "after splitting") gs
 117        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 118        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 119        gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
 120        mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
 121
 122        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 123        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
 124        mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
 125        -- Return: (a) CAFs used by this proc (b) a closure that will compute
 126        --  a new SRT for the procedure.
 127        let toTops topCAFEnv (topSRT, tops) =
 128              do let setSRT (topSRT, rst) g =
 129                       do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g
 130                          return (topSRT, gs : rst)
 131                 (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
 132                 gs' <- mapM finishInfoTables (concat gs')
 133                 pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $
 134                   return (topSRT, concat gs' : tops)
 135        return (localCAFs, toTops)
 136   where dflags = hsc_dflags hsc_env
 137         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 138         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
 139         run = runFuelIO (hsc_OptFuel hsc_env)
 140         dual_rewrite flag txt pass g =
 141           do dump flag ("Pre " ++ txt)  g
 142              g <- run $ pass g
 143              dump flag ("Post " ++ txt) $ g
 144              return g