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