CmmPipeline.hs 9.48 KB
Newer Older
1 2 3
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
4

Edward Z. Yang's avatar
Edward Z. Yang committed
5
module CmmPipeline (
6 7 8 9
  -- | Converts C-- with an implicit stack and native C-- calls into
  -- optimized, CPS converted and native-call-less C--.  The latter
  -- C-- can be used to generate assembly.
  cmmPipeline
10
) where
11

12
import CLabel
13
import Cmm
Simon Marlow's avatar
Simon Marlow committed
14
import CmmLint
15
import CmmLive
16 17
import CmmBuildInfoTables
import CmmCommonBlockElim
18
import CmmProcPoint
19
import CmmSpillReload
20
import CmmRewriteAssignments
21
import CmmStackLayout
22
import CmmContFlowOpt
23
import OptimizationFuel
24 25 26

import DynFlags
import ErrUtils
27 28
import HscTypes
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
29
import Control.Monad
30 31 32 33
import Data.Map (Map)
import qualified Data.Map as Map
import Outputable
import StaticFlags
34

35
-----------------------------------------------------------------------------
36
-- | Top level driver for C-- pipeline
37
-----------------------------------------------------------------------------
38 39 40 41 42 43 44 45 46 47 48 49 50
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
--    an analysis of the procedures to tell us what CAFs they use.
--    The first stage returns a map from procedure labels to CAFs,
--    along with a closure that will compute SRTs and attach them to
--    the compiled procedures.
--    The second stage is to combine the CAF information into a top-level
--    CAF environment mapping non-static closures to the CAFs they keep live,
--    then pass that environment to the closures returned in the first
--    stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
--    are computed for each procedure.
--    The SRT needs to be threaded because it is grown lazily.
51 52 53 54 55
-- 3. We run control flow optimizations twice, once before any pipeline
--    work is done, and once again at the very end on all of the
--    resulting C-- blocks.  EZY: It's unclear whether or not whether
--    we actually need to do the initial pass.
cmmPipeline  :: HscEnv -- Compilation env including
56
                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
Simon Peyton Jones's avatar
Simon Peyton Jones committed
57 58 59
             -> (TopSRT, [CmmGroup])    -- SRT table and accumulating list of compiled procs
             -> CmmGroup             -- Input C-- with Procedures
             -> IO (TopSRT, [CmmGroup]) -- Output CPS transformed C--
60
cmmPipeline hsc_env (topSRT, rst) prog =
61
  do let dflags = hsc_dflags hsc_env
62
     --
63
     showPass dflags "CPSZ"
64

65
     (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) prog
Simon Peyton Jones's avatar
Simon Peyton Jones committed
66
     -- tops :: [[(CmmDecl,CAFSet]]  (one list per group)
67

68
     let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
69 70

     -- folding over the groups
71
     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
72

73 74
     let cmms :: CmmGroup
         cmms = reverse (concat tops)
75

76
     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
77

Simon Marlow's avatar
Simon Marlow committed
78
     return (topSRT, cmms : rst)
79 80 81 82 83 84 85 86

{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}

87 88 89 90
-- EZY: It might be helpful to have an easy way of dumping the "pre"
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz

Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
92 93 94
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
95 96
       -- Why bother doing these early: dualLivenessWithInsertion,
       -- insertLateReloads, rewriteAssignments?
97

98
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
99
       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
100 101
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

102
       ----------- Eliminate common blocks -------------------
Simon Marlow's avatar
Simon Marlow committed
103
       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
104 105 106
       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
107 108

       ----------- Proc points -------------------
Simon Marlow's avatar
Simon Marlow committed
109 110 111
       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
       procPoints <- {-# SCC "minimalProcPointSet" #-} run $ minimalProcPointSet (targetPlatform dflags) callPPs g
       g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
112
       dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
113 114

       ----------- Spills and reloads -------------------
Simon Marlow's avatar
Simon Marlow committed
115
       g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g
116
       dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
117

118
       ----------- Sink and inline assignments -------------------
Simon Marlow's avatar
Simon Marlow committed
119
       g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g
120
       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
121 122

       ----------- Eliminate dead assignments -------------------
Simon Marlow's avatar
Simon Marlow committed
123
       g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g
124
       dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
125 126 127 128

       ----------- Zero dead stack slots (Debug only) ---------------
       -- Debugging: stubbing slots on death can cause crashes early
       g <- if opt_StubDeadValues
Simon Marlow's avatar
Simon Marlow committed
129
                then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
130
                else return g
131
       dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
132 133

       --------------- Stack layout ----------------
Simon Marlow's avatar
Simon Marlow committed
134
       slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
135
       let spEntryMap = getSpEntryMap entry_off g
136
       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
Simon Marlow's avatar
Simon Marlow committed
137
       let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
138 139 140
       mbpprTrace "areaMap" (ppr areaMap) $ return ()

       ------------  Manifest the stack pointer --------
Simon Marlow's avatar
Simon Marlow committed
141
       g  <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
142
       dump Opt_D_dump_cmmz_sp "Post manifestSP" g
143 144 145 146
       -- UGH... manifestSP can require updates to the procPointMap.
       -- We can probably do something quicker here for the update...

       ------------- Split into separate procedures ------------
Simon Marlow's avatar
Simon Marlow committed
147 148 149
       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g
       dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
       gs <- {-# SCC "splitAtProcPoints" #-} run $ splitAtProcPoints l callPPs procPoints procPointMap
150
                                       (CmmProc h l g)
Simon Marlow's avatar
Simon Marlow committed
151
       dumps Opt_D_dump_cmmz_split "Post splitting" gs
152 153

       ------------- More CAFs and foreign calls ------------
Simon Marlow's avatar
Simon Marlow committed
154
       cafEnv <- {-# SCC "cafAnal" #-} run $ cafAnal platform g
155 156
       let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
       mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
157

Simon Marlow's avatar
Simon Marlow committed
158 159
       gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
       dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
160 161

       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
162 163
       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
164 165

       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
Simon Marlow's avatar
Simon Marlow committed
166 167 168 169
       gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
170
       return (localCAFs, gs)
171

Simon Peyton Jones's avatar
Simon Peyton Jones committed
172
              -- gs        :: [ (CAFSet, CmmDecl) ]
173 174
              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)

175
  where dflags = hsc_dflags hsc_env
Simon Marlow's avatar
Simon Marlow committed
176 177 178
        platform = targetPlatform dflags
        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
                         | otherwise = z
179 180
        dump = dumpGraph dflags

Simon Marlow's avatar
Simon Marlow committed
181 182 183
        dumps flag name
           = mapM_ (dumpWith dflags (pprPlatform platform) flag name)

184 185 186 187 188 189
        -- Runs a required transformation/analysis
        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
        -- Runs an optional transformation/analysis (and should
        -- thus be subject to optimization fuel)
        runOptimization = runFuelIO (hsc_OptFuel hsc_env)

190

Simon Marlow's avatar
Simon Marlow committed
191 192
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
193
  cmmLint g
Simon Marlow's avatar
Simon Marlow committed
194 195 196 197 198 199 200 201 202 203
  dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g

dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
dumpWith dflags pprFun flag txt g = do
         -- ToDo: No easy way of say "dump all the cmmz, *and* split
         -- them into files."  Also, -ddump-cmmz doesn't play nicely
         -- with -ddump-to-file, since the headers get omitted.
   dumpIfSet_dyn dflags flag txt (pprFun g)
   when (not (dopt flag dflags)) $
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
204

205 206 207
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
208 209
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
                 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
210 211 212 213 214 215
toTops hsc_env topCAFEnv (topSRT, tops) gs =
  do let setSRT (topSRT, rst) g =
           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
              return (topSRT, gs : rst)
     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
     return (topSRT, concat gs' : tops)