CmmCPS.hs 7.52 KB
Newer Older
1 2 3
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
4

5 6 7
module CmmCPS (
  -- | Converts C-- with full proceedures and parameters
  -- to a CPS transformed C-- with the stack made manifest.
8 9
  -- Well, sort of.
  protoCmmCPS
10
) where
11

12
import CLabel
13
import Cmm
14 15 16
import CmmDecl
import CmmBuildInfoTables
import CmmCommonBlockElim
17
import CmmProcPoint
18 19 20
import CmmSpillReload
import CmmStackLayout
import OptimizationFuel
21 22 23

import DynFlags
import ErrUtils
24 25
import HscTypes
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
26
import Control.Monad
27 28 29 30
import Data.Map (Map)
import qualified Data.Map as Map
import Outputable
import StaticFlags
31

32 33 34
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
--    an analysis of the procedures to tell us what CAFs they use.
--    The first stage returns a map from procedure labels to CAFs,
--    along with a closure that will compute SRTs and attach them to
--    the compiled procedures.
--    The second stage is to combine the CAF information into a top-level
--    CAF environment mapping non-static closures to the CAFs they keep live,
--    then pass that environment to the closures returned in the first
--    stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
--    are computed for each procedure.
--    The SRT needs to be threaded because it is grown lazily.
protoCmmCPS  :: HscEnv -- Compilation env including
                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
             -> (TopSRT, [Cmm])    -- SRT table and accumulating list of compiled procs
             -> Cmm                -- Input C-- with Procedures
             -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) =
  do let dflags = hsc_dflags hsc_env
     showPass dflags "CPSZ"
     (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
     let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
     let cmms = Cmm (reverse (concat tops))
     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
     return (topSRT, cmms : rst)

{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}

70 71 72 73
-- EZY: It might be helpful to have an easy way of dumping the "pre"
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz

74 75 76 77
cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
78 79
       -- Why bother doing these early: dualLivenessWithInsertion,
       -- insertLateReloads, rewriteAssignments?
80

81 82 83
       ----------- Eliminate common blocks -------------------
       g <- return $ elimCommonBlocks g
       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
84 85 86 87 88 89
       -- Any work storing block Labels must be performed _after_ elimCommonBlocks

       ----------- Proc points -------------------
       let callPPs = callProcPoints g
       procPoints <- run $ minimalProcPointSet callPPs g
       g <- run $ addProcPointProtocols callPPs procPoints g
90
       dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
91 92

       ----------- Spills and reloads -------------------
93 94
       g <- run $ dualLivenessWithInsertion procPoints g
       dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
95

96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
       ----------- Sink and inline assignments -------------------
       g <- runOptimization $ rewriteAssignments g
       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g

       ----------- Eliminate dead assignments -------------------
       -- Remove redundant reloads (and any other redundant asst)
       g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
       dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g

       ----------- Zero dead stack slots (Debug only) ---------------
       -- Debugging: stubbing slots on death can cause crashes early
       g <- if opt_StubDeadValues
                then run $ stubSlotsOnDeath g
                else return g
       dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
111 112 113

       --------------- Stack layout ----------------
       slotEnv <- run $ liveSlotAnal g
114
       let spEntryMap = getSpEntryMap entry_off g
115
       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
116
       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
117 118 119
       mbpprTrace "areaMap" (ppr areaMap) $ return ()

       ------------  Manifest the stack pointer --------
120
       g  <- run $ manifestSP spEntryMap areaMap entry_off g
121
       dump Opt_D_dump_cmmz_sp "Post manifestSP" g
122 123 124 125 126
       -- UGH... manifestSP can require updates to the procPointMap.
       -- We can probably do something quicker here for the update...

       ------------- Split into separate procedures ------------
       procPointMap  <- run $ procPointAnalysis procPoints g
127
       dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
128 129
       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
                                       (CmmProc h l g)
130
       mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
131 132 133 134 135 136 137

       ------------- More CAFs and foreign calls ------------
       cafEnv <- run $ cafAnal g
       let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()

       gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
138
       mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
139 140

       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
141 142 143 144 145
       gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
       mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
       gs <- return $ map (bundleCAFs cafEnv) gs
       mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
       return (localCAFs, gs)
146 147
  where dflags = hsc_dflags hsc_env
        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
148 149 150 151 152 153 154
        dump f txt g = do
            -- ToDo: No easy way of say "dump all the cmmz, *and* split
            -- them into files."  Also, -ddump-cmmz doesn't play nicely
            -- with -ddump-to-file, since the headers get omitted.
            dumpIfSet_dyn dflags f txt (ppr g)
            when (not (dopt f dflags)) $
                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
155 156 157 158 159 160
        -- Runs a required transformation/analysis
        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
        -- Runs an optional transformation/analysis (and should
        -- thus be subject to optimization fuel)
        runOptimization = runFuelIO (hsc_OptFuel hsc_env)

161 162 163 164 165 166 167 168 169 170 171
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
                 -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
toTops hsc_env topCAFEnv (topSRT, tops) gs =
  do let setSRT (topSRT, rst) g =
           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
              return (topSRT, gs : rst)
     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
     return (topSRT, concat gs' : tops)