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