compiler/cmm/CmmPipeline.hs

   1 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
   2 -- Norman likes local bindings
   3 -- If this module lives on I'd like to get rid of this flag in due course
   4
   5 module CmmPipeline (
   6   -- | Converts C-- with an implicit stack and native C-- calls into
   7   -- optimized, CPS converted and native-call-less C--.  The latter
   8   -- C-- can be used to generate assembly.
   9   cmmPipeline
  10 ) where
  11
  12 import CLabel
  13 import Cmm
  14 import CmmDecl
  15 import CmmBuildInfoTables
  16 import CmmCommonBlockElim
  17 import CmmProcPoint
  18 import CmmSpillReload
  19 import CmmStackLayout
  20 import CmmContFlowOpt
  21 import OptimizationFuel
  22
  23 import DynFlags
  24 import ErrUtils
  25 import HscTypes
  26 import Data.Maybe
  27 import Control.Monad
  28 import Data.Map (Map)
  29 import qualified Data.Map as Map
  30 import Outputable
  31 import StaticFlags
  32
  33 -----------------------------------------------------------------------------
  34 -- | Top level driver for C-- pipeline
  35 -----------------------------------------------------------------------------
  36 -- There are two complications here:
  37 -- 1. We need to compile the procedures in two stages because we need
  38 --    an analysis of the procedures to tell us what CAFs they use.
  39 --    The first stage returns a map from procedure labels to CAFs,
  40 --    along with a closure that will compute SRTs and attach them to
  41 --    the compiled procedures.
  42 --    The second stage is to combine the CAF information into a top-level
  43 --    CAF environment mapping non-static closures to the CAFs they keep live,
  44 --    then pass that environment to the closures returned in the first
  45 --    stage of compilation.
  46 -- 2. We need to thread the module's SRT around when the SRT tables
  47 --    are computed for each procedure.
  48 --    The SRT needs to be threaded because it is grown lazily.
  49 -- 3. We run control flow optimizations twice, once before any pipeline
  50 --    work is done, and once again at the very end on all of the
  51 --    resulting C-- blocks.  EZY: It's unclear whether or not whether
  52 --    we actually need to do the initial pass.
  53 cmmPipeline  :: HscEnv -- Compilation env including
  54                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  55              -> (TopSRT, [Cmm])    -- SRT table and accumulating list of compiled procs
  56              -> Cmm                -- Input C-- with Procedures
  57              -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
  58 cmmPipeline hsc_env (topSRT, rst) prog =
  59   do let dflags = hsc_dflags hsc_env
  60          (Cmm tops) = runCmmContFlowOpts prog
  61      showPass dflags "CPSZ"
  62      (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
  63      let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
  64      (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
  65      let cmms = Cmm (reverse (concat tops))
  66      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
  67      -- SRT is not affected by control flow optimization pass
  68      let prog' = map runCmmContFlowOpts (cmms : rst)
  69      return (topSRT, prog')
  70
  71 {- [Note global fuel]
  72 ~~~~~~~~~~~~~~~~~~~~~
  73 The identity and the last pass are stored in
  74 mutable reference cells in an 'HscEnv' and are
  75 global to one compiler session.
  76 -}
  77
  78 -- EZY: It might be helpful to have an easy way of dumping the "pre"
  79 -- input for any given phase, besides just turning it all on with
  80 -- -ddump-cmmz
  81
  82 cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
  83 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
  84 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
  85     do
  86        -- Why bother doing these early: dualLivenessWithInsertion,
  87        -- insertLateReloads, rewriteAssignments?
  88
  89        ----------- Eliminate common blocks -------------------
  90        g <- return $ elimCommonBlocks g
  91        dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
  92        -- Any work storing block Labels must be performed _after_ elimCommonBlocks
  93
  94        ----------- Proc points -------------------
  95        let callPPs = callProcPoints g
  96        procPoints <- run $ minimalProcPointSet callPPs g
  97        g <- run $ addProcPointProtocols callPPs procPoints g
  98        dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
  99
 100        ----------- Spills and reloads -------------------
 101        g <- run $ dualLivenessWithInsertion procPoints g
 102        dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
 103
 104        ----------- Sink and inline assignments -------------------
 105        g <- runOptimization $ rewriteAssignments g
 106        dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
 107
 108        ----------- Eliminate dead assignments -------------------
 109        -- Remove redundant reloads (and any other redundant asst)
 110        g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
 111        dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
 112
 113        ----------- Zero dead stack slots (Debug only) ---------------
 114        -- Debugging: stubbing slots on death can cause crashes early
 115        g <- if opt_StubDeadValues
 116                 then run $ stubSlotsOnDeath g
 117                 else return g
 118        dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
 119
 120        --------------- Stack layout ----------------
 121        slotEnv <- run $ liveSlotAnal g
 122        let spEntryMap = getSpEntryMap entry_off g
 123        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 124        let areaMap = layout procPoints spEntryMap slotEnv entry_off g
 125        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 126
 127        ------------  Manifest the stack pointer --------
 128        g  <- run $ manifestSP spEntryMap areaMap entry_off g
 129        dump Opt_D_dump_cmmz_sp "Post manifestSP" g
 130        -- UGH... manifestSP can require updates to the procPointMap.
 131        -- We can probably do something quicker here for the update...
 132
 133        ------------- Split into separate procedures ------------
 134        procPointMap  <- run $ procPointAnalysis procPoints g
 135        dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
 136        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
 137                                        (CmmProc h l g)
 138        mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
 139
 140        ------------- More CAFs and foreign calls ------------
 141        cafEnv <- run $ cafAnal g
 142        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 143        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 144
 145        gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
 146        mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
 147
 148        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 149        gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
 150        mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
 151        gs <- return $ map (bundleCAFs cafEnv) gs
 152        mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
 153        return (localCAFs, gs)
 154   where dflags = hsc_dflags hsc_env
 155         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 156         dump f txt g = do
 157             -- ToDo: No easy way of say "dump all the cmmz, *and* split
 158             -- them into files."  Also, -ddump-cmmz doesn't play nicely
 159             -- with -ddump-to-file, since the headers get omitted.
 160             dumpIfSet_dyn dflags f txt (ppr g)
 161             when (not (dopt f dflags)) $
 162                 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
 163         -- Runs a required transformation/analysis
 164         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
 165         -- Runs an optional transformation/analysis (and should
 166         -- thus be subject to optimization fuel)
 167         runOptimization = runFuelIO (hsc_OptFuel hsc_env)
 168
 169 -- This probably belongs in CmmBuildInfoTables?
 170 -- We're just finishing the job here: once we know what CAFs are defined
 171 -- in non-static closures, we can build the SRTs.
 172 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
 173                  -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
 174 toTops hsc_env topCAFEnv (topSRT, tops) gs =
 175   do let setSRT (topSRT, rst) g =
 176            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
 177               return (topSRT, gs : rst)
 178      (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
 179      return (topSRT, concat gs' : tops)