compiler/cmm/CmmCPS.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 CmmCPS (
   6   -- | Converts C-- with full proceedures and parameters
   7   -- to a CPS transformed C-- with the stack made manifest.
   8   -- Well, sort of.
   9   protoCmmCPS
  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 OptimizationFuel
  21
  22 import DynFlags
  23 import ErrUtils
  24 import HscTypes
  25 import Data.Maybe
  26 import Control.Monad
  27 import Data.Map (Map)
  28 import qualified Data.Map as Map
  29 import Outputable
  30 import StaticFlags
  31
  32 -----------------------------------------------------------------------------
  33 -- |Top level driver for the CPS pass
  34 -----------------------------------------------------------------------------
  35 -- There are two complications here:
  36 -- 1. We need to compile the procedures in two stages because we need
  37 --    an analysis of the procedures to tell us what CAFs they use.
  38 --    The first stage returns a map from procedure labels to CAFs,
  39 --    along with a closure that will compute SRTs and attach them to
  40 --    the compiled procedures.
  41 --    The second stage is to combine the CAF information into a top-level
  42 --    CAF environment mapping non-static closures to the CAFs they keep live,
  43 --    then pass that environment to the closures returned in the first
  44 --    stage of compilation.
  45 -- 2. We need to thread the module's SRT around when the SRT tables
  46 --    are computed for each procedure.
  47 --    The SRT needs to be threaded because it is grown lazily.
  48 protoCmmCPS  :: HscEnv -- Compilation env including
  49                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  50              -> (TopSRT, [Cmm])    -- SRT table and accumulating list of compiled procs
  51              -> Cmm                -- Input C-- with Procedures
  52              -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
  53 protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) =
  54   do let dflags = hsc_dflags hsc_env
  55      showPass dflags "CPSZ"
  56      (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
  57      let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
  58      (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
  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 -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
  71 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
  72 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
  73     do
  74        -- Why bother doing it this early?
  75        -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
  76        --                       (dualLivenessWithInsertion callPPs) g
  77        -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
  78        -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
  79        --                   (removeDeadAssignmentsAndReloads callPPs) g
  80        dump Opt_D_dump_cmmz "Pre common block elimination" g
  81        g <- return $ elimCommonBlocks g
  82        dump Opt_D_dump_cmmz "Post common block elimination" g
  83
  84        -- Any work storing block Labels must be performed _after_ elimCommonBlocks
  85
  86        ----------- Proc points -------------------
  87        let callPPs = callProcPoints g
  88        procPoints <- run $ minimalProcPointSet callPPs g
  89        g <- run $ addProcPointProtocols callPPs procPoints g
  90        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  91
  92        ----------- Spills and reloads -------------------
  93        g     <-
  94               -- pprTrace "pre Spills" (ppr g) $
  95                 dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
  96                              (dualLivenessWithInsertion procPoints) g
  97                     -- Insert spills at defns; reloads at return points
  98        g     <-
  99               -- pprTrace "pre insertLateReloads" (ppr g) $
 100                 runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
 101        dump Opt_D_dump_cmmz "Post late reloads" g
 102        g     <-
 103                -- pprTrace "post insertLateReloads" (ppr g) $
 104                 dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
 105                                         (removeDeadAssignmentsAndReloads procPoints) g
 106                     -- Remove redundant reloads (and any other redundant asst)
 107
 108        ----------- Debug only: add code to put zero in dead stack slots----
 109        -- Debugging: stubbing slots on death can cause crashes early
 110        g <- -- trace "post dead-assign elim" $
 111             if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
 112
 113
 114        --------------- Stack layout ----------------
 115        slotEnv <- run $ liveSlotAnal g
 116        let spEntryMap = getSpEntryMap entry_off g
 117        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 118        let areaMap = layout procPoints spEntryMap slotEnv entry_off g
 119        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 120
 121        ------------  Manifest the stack pointer --------
 122        g  <- run $ manifestSP spEntryMap areaMap entry_off g
 123        dump Opt_D_dump_cmmz "after manifestSP" g
 124        -- UGH... manifestSP can require updates to the procPointMap.
 125        -- We can probably do something quicker here for the update...
 126
 127        ------------- Split into separate procedures ------------
 128        procPointMap  <- run $ procPointAnalysis procPoints g
 129        dump Opt_D_dump_cmmz "procpoint map" procPointMap
 130        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
 131                                        (CmmProc h l g)
 132        mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
 133
 134        ------------- More CAFs and foreign calls ------------
 135        cafEnv <- run $ cafAnal g
 136        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 137        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 138
 139        gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
 140        mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
 141
 142        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 143        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
 144        mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
 145        let gs'' = map (bundleCAFs cafEnv) gs'
 146        mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
 147        return (localCAFs, gs'')
 148   where dflags = hsc_dflags hsc_env
 149         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 150         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
 151         -- Runs a required transformation/analysis
 152         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
 153         -- Runs an optional transformation/analysis (and should
 154         -- thus be subject to optimization fuel)
 155         runOptimization = runFuelIO (hsc_OptFuel hsc_env)
 156
 157         -- pass 'run' or 'runOptimization' for 'r'
 158         dual_rewrite r flag txt pass g =
 159           do dump flag ("Pre " ++ txt)  g
 160              g <- r $ pass g
 161              dump flag ("Post " ++ txt) $ g
 162              return g
 163
 164 -- This probably belongs in CmmBuildInfoTables?
 165 -- We're just finishing the job here: once we know what CAFs are defined
 166 -- in non-static closures, we can build the SRTs.
 167 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
 168                  -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
 169 toTops hsc_env topCAFEnv (topSRT, tops) gs =
 170   do let setSRT (topSRT, rst) g =
 171            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
 172               return (topSRT, gs : rst)
 173      (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
 174      return (topSRT, concat gs' : tops)