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