compiler/cmm/CmmCPSZ.hs

   1 #if __GLASGOW_HASKELL__ >= 611
   2 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
   3 #endif
   4 -- Norman likes local bindings
   5 -- If this module lives on I'd like to get rid of this flag in due course
   6
   7 module CmmCPSZ (
   8   -- | Converts C-- with full proceedures and parameters
   9   -- to a CPS transformed C-- with the stack made manifest.
  10   -- Well, sort of.
  11   protoCmmCPSZ
  12 ) where
  13
  14 import CLabel
  15 import Cmm
  16 import CmmBuildInfoTables
  17 import CmmCommonBlockElimZ
  18 import CmmProcPointZ
  19 import CmmSpillReload
  20 import CmmStackLayout
  21 import DFMonad
  22 import PprCmmZ()
  23 import ZipCfgCmmRep
  24
  25 import DynFlags
  26 import ErrUtils
  27 import HscTypes
  28 import Data.Maybe
  29 import Control.Monad
  30 import Data.Map (Map)
  31 import qualified Data.Map as Map
  32 import Outputable
  33 import StaticFlags
  34
  35 -----------------------------------------------------------------------------
  36 -- |Top level driver for the CPS pass
  37 -----------------------------------------------------------------------------
  38 -- There are two complications here:
  39 -- 1. We need to compile the procedures in two stages because we need
  40 --    an analysis of the procedures to tell us what CAFs they use.
  41 --    The first stage returns a map from procedure labels to CAFs,
  42 --    along with a closure that will compute SRTs and attach them to
  43 --    the compiled procedures.
  44 --    The second stage is to combine the CAF information into a top-level
  45 --    CAF environment mapping non-static closures to the CAFs they keep live,
  46 --    then pass that environment to the closures returned in the first
  47 --    stage of compilation.
  48 -- 2. We need to thread the module's SRT around when the SRT tables
  49 --    are computed for each procedure.
  50 --    The SRT needs to be threaded because it is grown lazily.
  51 protoCmmCPSZ :: HscEnv -- Compilation env including
  52                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
  53              -> (TopSRT, [CmmZ])  -- SRT table and accumulating list of compiled procs
  54              -> CmmZ              -- Input C-- with Procedures
  55              -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
  56 protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) =
  57   do let dflags = hsc_dflags hsc_env
  58      showPass dflags "CPSZ"
  59      (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
  60      let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
  61      (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
  62      -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
  63      let cmms = Cmm (reverse (concat tops))
  64      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
  65      return (topSRT, cmms : rst)
  66
  67 {- [Note global fuel]
  68 ~~~~~~~~~~~~~~~~~~~~~
  69 The identity and the last pass are stored in
  70 mutable reference cells in an 'HscEnv' and are
  71 global to one compiler session.
  72 -}
  73
  74 cpsTop :: HscEnv -> CmmTopZ ->
  75           IO ([(CLabel, CAFSet)],
  76               [(CAFSet, CmmTopForInfoTables)])
  77 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])
  78 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
  79     do
  80        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
  81        let callPPs = callProcPoints g
  82        -- Why bother doing it this early?
  83        -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
  84        --                       (dualLivenessWithInsertion callPPs) g
  85        -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
  86        -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
  87        --                   (removeDeadAssignmentsAndReloads callPPs) g
  88        dump Opt_D_dump_cmmz "Pre common block elimination" g
  89        g <- return $ elimCommonBlocks g
  90        dump Opt_D_dump_cmmz "Post common block elimination" g
  91
  92        ----------- Proc points -------------------
  93        procPoints <- run $ minimalProcPointSet callPPs g
  94        g <- run $ addProcPointProtocols callPPs procPoints g
  95        dump Opt_D_dump_cmmz "Post Proc Points Added" g
  96
  97        ----------- Spills and reloads -------------------
  98        g     <-
  99               -- pprTrace "pre Spills" (ppr g) $
 100                 dual_rewrite Opt_D_dump_cmmz "spills and reloads"
 101                              (dualLivenessWithInsertion procPoints) g
 102                     -- Insert spills at defns; reloads at return points
 103        g     <-
 104               -- pprTrace "pre insertLateReloads" (ppr g) $
 105                 run $ insertLateReloads g -- Duplicate reloads just before uses
 106        dump Opt_D_dump_cmmz "Post late reloads" g
 107        g     <-
 108                -- pprTrace "post insertLateReloads" (ppr g) $
 109                 dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
 110                                         (removeDeadAssignmentsAndReloads procPoints) g
 111                     -- Remove redundant reloads (and any other redundant asst)
 112
 113        ----------- Debug only: add code to put zero in dead stack slots----
 114        -- Debugging: stubbing slots on death can cause crashes early
 115        g <-
 116            -- trace "post dead-assign elim" $
 117             if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
 118
 119
 120        --------------- Stack layout ----------------
 121        slotEnv <- run $ liveSlotAnal g
 122        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 123        -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
 124        -- (cafEnv, slotEnv) <-
 125        --  -- trace "post print cafAnal" $
 126        --    return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
 127        slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
 128        mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
 129        let areaMap = layout procPoints slotEnv entry_off g
 130        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 131
 132        ------------  Manifest the the stack pointer --------
 133        g  <- run $ manifestSP areaMap entry_off g
 134        dump Opt_D_dump_cmmz "after manifestSP" g
 135        -- UGH... manifestSP can require updates to the procPointMap.
 136        -- We can probably do something quicker here for the update...
 137
 138        ------------- Split into separate procedures ------------
 139        procPointMap  <- run $ procPointAnalysis procPoints g
 140        dump Opt_D_dump_cmmz "procpoint map" procPointMap
 141        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
 142                                        (CmmProc h l args (stackInfo, g))
 143        mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
 144
 145        ------------- More CAFs and foreign calls ------------
 146        cafEnv <- run $ cafAnal g
 147        cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv  g
 148        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 149        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 150
 151        gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
 152        mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
 153
 154        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 155        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
 156        mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
 157        let gs'' = map (bundleCAFs cafEnv) gs'
 158        mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
 159        return (localCAFs, gs'')
 160   where dflags = hsc_dflags hsc_env
 161         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 162         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
 163
 164         run :: FuelMonad a -> IO a
 165         run = runFuelIO (hsc_OptFuel hsc_env)
 166
 167         dual_rewrite flag txt pass g =
 168           do dump flag ("Pre " ++ txt)  g
 169              g <- run $ pass g
 170              dump flag ("Post " ++ txt) $ g
 171              return g
 172
 173 -- This probably belongs in CmmBuildInfoTables?
 174 -- We're just finishing the job here: once we know what CAFs are defined
 175 -- in non-static closures, we can build the SRTs.
 176 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
 177                  -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
 178
 179 toTops hsc_env topCAFEnv (topSRT, tops) gs =
 180   do let setSRT (topSRT, rst) g =
 181            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
 182               return (topSRT, gs : rst)
 183      (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
 184      gs' <- mapM finishInfoTables (concat gs')
 185      return (topSRT, concat gs' : tops)