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 Data.Maybe
  24 import Control.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 accumulating list of compiled procs
  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_TryNewCodeGen (hsc_dflags hsc_env))
  51   = return (topSRT, Cmm tops : rst)                -- Only if -fnew-codegen
  52   | otherwise
  53   = do  let dflags = hsc_dflags hsc_env
  54         showPass dflags "CPSZ"
  55         (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
  56         let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
  57         (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
  58         -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
  59         let cmms = Cmm (reverse (concat tops))
  60         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
  61         return (topSRT, cmms : rst)
  62
  63 {- [Note global fuel]
  64 ~~~~~~~~~~~~~~~~~~~~~
  65 The identity and the last pass are stored in
  66 mutable reference cells in an 'HscEnv' and are
  67 global to one compiler session.
  68 -}
  69
  70 cpsTop :: HscEnv -> CmmTopZ ->
  71           IO ([(CLabel, CAFSet)],
  72               [(CAFSet, CmmTopForInfoTables)])
  73 cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
  74 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
  75     do
  76        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  77        let callPPs = callProcPoints g
  78        -- Why bother doing it this early?
  79        -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  80        --                       (dualLivenessWithInsertion callPPs) g
  81        -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
  82        -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  83        --                   (removeDeadAssignmentsAndReloads callPPs) g
  84        dump Opt_D_dump_cmmz "Pre common block elimination" g
  85        g <- return $ elimCommonBlocks g
  86        dump Opt_D_dump_cmmz "Post common block elimination" g
  87
  88        ----------- Proc points -------------------
  89        procPoints <- run $ minimalProcPointSet callPPs g
  90        g <- run $ addProcPointProtocols callPPs procPoints g
  91        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  92
  93        ----------- Spills and reloads -------------------
  94        g     <-
  95               -- pprTrace "pre Spills" (ppr g) $
  96                 dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  97                              (dualLivenessWithInsertion procPoints) g
  98                     -- Insert spills at defns; reloads at return points
  99        g     <-
 100               -- pprTrace "pre insertLateReloads" (ppr g) $
 101                 run $ insertLateReloads g -- Duplicate reloads just before uses
 102        dump Opt_D_dump_cmmz "Post late reloads" g
 103        g     <-
 104                -- pprTrace "post insertLateReloads" (ppr g) $
 105                 dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
 106                                         (removeDeadAssignmentsAndReloads procPoints) g
 107                     -- Remove redundant reloads (and any other redundant asst)
 108
 109        ----------- Debug only: add code to put zero in dead stack slots----
 110        -- Debugging: stubbing slots on death can cause crashes early
 111        g <-
 112            -- trace "post dead-assign elim" $
 113             if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
 114
 115
 116        --------------- Stack layout ----------------
 117        slotEnv <- run $ liveSlotAnal g
 118        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 119        -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
 120        -- (cafEnv, slotEnv) <-
 121        --  -- trace "post print cafAnal" $
 122        --    return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
 123        slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
 124        mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
 125        let areaMap = layout procPoints slotEnv entry_off g
 126        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 127
 128        ------------  Manifest the the stack pointer --------
 129        g  <- run $ manifestSP areaMap entry_off g
 130        dump Opt_D_dump_cmmz "after manifestSP" g
 131        -- UGH... manifestSP can require updates to the procPointMap.
 132        -- We can probably do something quicker here for the update...
 133
 134        ------------- Split into separate procedures ------------
 135        procPointMap  <- run $ procPointAnalysis procPoints g
 136        dump Opt_D_dump_cmmz "procpoint map" procPointMap
 137        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
 138                                        (CmmProc h l args (stackInfo, g))
 139        mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
 140
 141        ------------- More CAFs and foreign calls ------------
 142        cafEnv <- run $ cafAnal g
 143        cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv  g
 144        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 145        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 146
 147        gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
 148        mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
 149
 150        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 151        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
 152        mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
 153        let gs'' = map (bundleCAFs cafEnv) gs'
 154        mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
 155        return (localCAFs, gs'')
 156   where dflags = hsc_dflags hsc_env
 157         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 158         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
 159         run = runFuelIO (hsc_OptFuel hsc_env)
 160         dual_rewrite flag txt pass g =
 161           do dump flag ("Pre " ++ txt)  g
 162              g <- run $ pass g
 163              dump flag ("Post " ++ txt) $ g
 164              return g
 165
 166 -- This probably belongs in CmmBuildInfoTables?
 167 -- We're just finishing the job here: once we know what CAFs are defined
 168 -- in non-static closures, we can build the SRTs.
 169 toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
 170                  -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
 171
 172 toTops hsc_env topCAFEnv (topSRT, tops) gs =
 173   do let setSRT (topSRT, rst) g =
 174            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
 175               return (topSRT, gs : rst)
 176      (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
 177      gs' <- mapM finishInfoTables (concat gs')
 178      return (topSRT, concat gs' : tops)