More codegen refactoring with simonpj
[ghc.git] / compiler / cmm / CmmPipeline.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 CmmPipeline (
6 -- | Converts C-- with an implicit stack and native C-- calls into
7 -- optimized, CPS converted and native-call-less C--. The latter
8 -- C-- can be used to generate assembly.
9 cmmPipeline
10 ) where
11
12 import CLabel
13 import Cmm
14 import CmmLive
15 import CmmBuildInfoTables
16 import CmmCommonBlockElim
17 import CmmProcPoint
18 import CmmSpillReload
19 import CmmRewriteAssignments
20 import CmmStackLayout
21 import CmmContFlowOpt
22 import OptimizationFuel
23
24 import DynFlags
25 import ErrUtils
26 import HscTypes
27 import Data.Maybe
28 import Control.Monad
29 import Data.Map (Map)
30 import qualified Data.Map as Map
31 import Outputable
32 import StaticFlags
33
34 -----------------------------------------------------------------------------
35 -- | Top level driver for C-- pipeline
36 -----------------------------------------------------------------------------
37 -- There are two complications here:
38 -- 1. We need to compile the procedures in two stages because we need
39 -- an analysis of the procedures to tell us what CAFs they use.
40 -- The first stage returns a map from procedure labels to CAFs,
41 -- along with a closure that will compute SRTs and attach them to
42 -- the compiled procedures.
43 -- The second stage is to combine the CAF information into a top-level
44 -- CAF environment mapping non-static closures to the CAFs they keep live,
45 -- then pass that environment to the closures returned in the first
46 -- stage of compilation.
47 -- 2. We need to thread the module's SRT around when the SRT tables
48 -- are computed for each procedure.
49 -- The SRT needs to be threaded because it is grown lazily.
50 -- 3. We run control flow optimizations twice, once before any pipeline
51 -- work is done, and once again at the very end on all of the
52 -- resulting C-- blocks. EZY: It's unclear whether or not whether
53 -- we actually need to do the initial pass.
54 cmmPipeline :: HscEnv -- Compilation env including
55 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
56 -> (TopSRT, [CmmGroup]) -- SRT table and accumulating list of compiled procs
57 -> CmmGroup -- Input C-- with Procedures
58 -> IO (TopSRT, [CmmGroup]) -- Output CPS transformed C--
59 cmmPipeline hsc_env (topSRT, rst) prog =
60 do let dflags = hsc_dflags hsc_env
61 --
62 showPass dflags "CPSZ"
63
64 (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) prog
65 -- tops :: [[(CmmDecl,CAFSet]] (one list per group)
66
67 let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
68
69 -- folding over the groups
70 (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
71
72 let cmms :: CmmGroup
73 cmms = reverse (concat tops)
74
75 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
76
77 -- SRT is not affected by control flow optimization pass
78 let prog' = runCmmContFlowOpts cmms
79
80 return (topSRT, prog' : rst)
81
82 {- [Note global fuel]
83 ~~~~~~~~~~~~~~~~~~~~~
84 The identity and the last pass are stored in
85 mutable reference cells in an 'HscEnv' and are
86 global to one compiler session.
87 -}
88
89 -- EZY: It might be helpful to have an easy way of dumping the "pre"
90 -- input for any given phase, besides just turning it all on with
91 -- -ddump-cmmz
92
93 cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
94 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
95 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
96 do
97 -- Why bother doing these early: dualLivenessWithInsertion,
98 -- insertLateReloads, rewriteAssignments?
99
100 ----------- Control-flow optimisations ---------------
101 g <- return $ cmmCfgOpts g
102 dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
103
104 ----------- Eliminate common blocks -------------------
105 g <- return $ elimCommonBlocks g
106 dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
107 -- Any work storing block Labels must be performed _after_
108 -- elimCommonBlocks
109
110 ----------- Proc points -------------------
111 let callPPs = callProcPoints g
112 procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
113 g <- run $ addProcPointProtocols callPPs procPoints g
114 dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
115
116 ----------- Spills and reloads -------------------
117 g <- run $ dualLivenessWithInsertion procPoints g
118 dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
119
120 ----------- Sink and inline assignments -------------------
121 g <- runOptimization $ rewriteAssignments platform g
122 dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
123
124 ----------- Eliminate dead assignments -------------------
125 g <- runOptimization $ removeDeadAssignments g
126 dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
127
128 ----------- Zero dead stack slots (Debug only) ---------------
129 -- Debugging: stubbing slots on death can cause crashes early
130 g <- if opt_StubDeadValues
131 then run $ stubSlotsOnDeath g
132 else return g
133 dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
134
135 --------------- Stack layout ----------------
136 slotEnv <- run $ liveSlotAnal g
137 let spEntryMap = getSpEntryMap entry_off g
138 mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
139 let areaMap = layout procPoints spEntryMap slotEnv entry_off g
140 mbpprTrace "areaMap" (ppr areaMap) $ return ()
141
142 ------------ Manifest the stack pointer --------
143 g <- run $ manifestSP spEntryMap areaMap entry_off g
144 dump Opt_D_dump_cmmz_sp "Post manifestSP" g
145 -- UGH... manifestSP can require updates to the procPointMap.
146 -- We can probably do something quicker here for the update...
147
148 ------------- Split into separate procedures ------------
149 procPointMap <- run $ procPointAnalysis procPoints g
150 dumpWith ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
151 gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
152 (CmmProc h l g)
153 mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
154
155 ------------- More CAFs and foreign calls ------------
156 cafEnv <- run $ cafAnal platform g
157 let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
158 mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
159
160 gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
161 mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
162
163 ----------- Control-flow optimisations ---------------
164 gs <- return $ map cmmCfgOpts gs
165 mapM_ (dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations") gs
166
167 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
168 gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
169 mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
170 gs <- return $ map (bundleCAFs cafEnv) gs
171 mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
172 return (localCAFs, gs)
173
174 -- gs :: [ (CAFSet, CmmDecl) ]
175 -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
176
177 where dflags = hsc_dflags hsc_env
178 mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
179 dump = dumpGraph dflags
180
181 -- Runs a required transformation/analysis
182 run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
183 -- Runs an optional transformation/analysis (and should
184 -- thus be subject to optimization fuel)
185 runOptimization = runFuelIO (hsc_OptFuel hsc_env)
186
187
188 dumpGraph :: DynFlags -> DynFlag -> CmmGraph -> IO ()
189 dumpGraph dflags flag g = do
190 cmmLint g
191 dumpWith (pprPlatform platform)
192 where
193 platform = targetPlatform dflags
194
195 dumpWith pprFun flag txt g = do
196 -- ToDo: No easy way of say "dump all the cmmz, *and* split
197 -- them into files." Also, -ddump-cmmz doesn't play nicely
198 -- with -ddump-to-file, since the headers get omitted.
199 dumpIfSet_dyn dflags flag txt (pprFun g)
200 when (not (dopt flag dflags)) $
201 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
202
203 -- This probably belongs in CmmBuildInfoTables?
204 -- We're just finishing the job here: once we know what CAFs are defined
205 -- in non-static closures, we can build the SRTs.
206 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
207 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
208 toTops hsc_env topCAFEnv (topSRT, tops) gs =
209 do let setSRT (topSRT, rst) g =
210 do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
211 return (topSRT, gs : rst)
212 (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
213 return (topSRT, concat gs' : tops)