Rename all of the 'cmmz' flags and make them more consistent.
[ghc.git] / compiler / cmm / CmmPipeline.hs
1 {-# LANGUAGE NoMonoLocalBinds #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this extension 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 Cmm
13 import CmmLint
14 import CmmBuildInfoTables
15 import CmmCommonBlockElim
16 import CmmProcPoint
17 import CmmContFlowOpt
18 import CmmLayoutStack
19 import CmmSink
20 import Hoopl
21
22 import UniqSupply
23 import DynFlags
24 import ErrUtils
25 import HscTypes
26 import Control.Monad
27 import Outputable
28 import Platform
29
30 -----------------------------------------------------------------------------
31 -- | Top level driver for C-- pipeline
32 -----------------------------------------------------------------------------
33
34 cmmPipeline :: HscEnv -- Compilation env including
35 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
36 -> TopSRT -- SRT table and accumulating list of compiled procs
37 -> CmmGroup -- Input C-- with Procedures
38 -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
39
40 cmmPipeline hsc_env topSRT prog =
41 do let dflags = hsc_dflags hsc_env
42
43 showPass dflags "CPSZ"
44
45 tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
46
47 (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
48 dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms
49
50 return (topSRT, cmms)
51
52
53 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
54 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
55 cpsTop hsc_env proc =
56 do
57 ----------- Control-flow optimisations ----------------------------------
58
59 -- The first round of control-flow optimisation speeds up the
60 -- later passes by removing lots of empty blocks, so we do it
61 -- even when optimisation isn't turned on.
62 --
63 CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
64 return $ cmmCfgOptsProc splitting_proc_points proc
65 dump Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
66
67 let !TopInfo {stack_info=StackInfo { arg_space = entry_off
68 , do_layout = do_layout }} = h
69
70 ----------- Eliminate common blocks -------------------------------------
71 g <- {-# SCC "elimCommonBlocks" #-}
72 condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
73 Opt_D_dump_cmm_cbe "Post common block elimination"
74
75 -- Any work storing block Labels must be performed _after_
76 -- elimCommonBlocks
77
78 ----------- Proc points -------------------------------------------------
79 let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
80 proc_points <-
81 if splitting_proc_points
82 then {-# SCC "minimalProcPointSet" #-} runUniqSM $
83 minimalProcPointSet (targetPlatform dflags) call_pps g
84 else
85 return call_pps
86
87 let noncall_pps = proc_points `setDifference` call_pps
88 when (not (setNull noncall_pps) && dopt Opt_D_dump_cmm dflags) $
89 pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
90
91 ----------- Sink and inline assignments *before* stack layout -----------
92 {- Maybe enable this later
93 g <- {-# SCC "sink1" #-}
94 condPass Opt_CmmSink (cmmSink dflags) g
95 Opt_D_dump_cmm_rewrite "Sink assignments (1)"
96 -}
97
98 ----------- Layout the stack and manifest Sp ----------------------------
99 (g, stackmaps) <-
100 {-# SCC "layoutStack" #-}
101 if do_layout
102 then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
103 else return (g, mapEmpty)
104 dump Opt_D_dump_cmm_sp "Layout Stack" g
105
106 ----------- Sink and inline assignments *after* stack layout ------------
107 g <- {-# SCC "sink2" #-}
108 condPass Opt_CmmSink (cmmSink dflags) g
109 Opt_D_dump_cmm_rewrite "Sink assignments (2)"
110
111 ------------- CAF analysis ----------------------------------------------
112 let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
113 dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv)
114
115 if splitting_proc_points
116 then do
117 ------------- Split into separate procedures -----------------------
118 pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $
119 procPointAnalysis proc_points g
120 dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map
121 gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
122 splitAtProcPoints dflags l call_pps proc_points pp_map
123 (CmmProc h l v g)
124 dumps Opt_D_dump_cmm_split "Post splitting" gs
125
126 ------------- Populate info tables with stack info -----------------
127 gs <- {-# SCC "setInfoTableStackMap" #-}
128 return $ map (setInfoTableStackMap dflags stackmaps) gs
129 dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" gs
130
131 ----------- Control-flow optimisations -----------------------------
132 gs <- {-# SCC "cmmCfgOpts(2)" #-}
133 return $ if optLevel dflags >= 1
134 then map (cmmCfgOptsProc splitting_proc_points) gs
135 else gs
136 gs <- return (map removeUnreachableBlocksProc gs)
137 -- Note [unreachable blocks]
138 dumps Opt_D_dump_cmm_cfg "Post control-flow optimsations" gs
139
140 return (cafEnv, gs)
141
142 else do
143 -- attach info tables to return points
144 g <- return $ attachContInfoTables call_pps (CmmProc h l v g)
145
146 ------------- Populate info tables with stack info -----------------
147 g <- {-# SCC "setInfoTableStackMap" #-}
148 return $ setInfoTableStackMap dflags stackmaps g
149 dump' Opt_D_dump_cmm_info "after setInfoTableStackMap" g
150
151 ----------- Control-flow optimisations -----------------------------
152 g <- {-# SCC "cmmCfgOpts(2)" #-}
153 return $ if optLevel dflags >= 1
154 then cmmCfgOptsProc splitting_proc_points g
155 else g
156 g <- return (removeUnreachableBlocksProc g)
157 -- Note [unreachable blocks]
158 dump' Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
159
160 return (cafEnv, [g])
161
162 where dflags = hsc_dflags hsc_env
163 platform = targetPlatform dflags
164 dump = dumpGraph dflags
165 dump' = dumpWith dflags
166
167 dumps flag name
168 = mapM_ (dumpWith dflags flag name)
169
170 condPass flag pass g dumpflag dumpname =
171 if gopt flag dflags
172 then do
173 g <- return $ pass g
174 dump dumpflag dumpname g
175 return g
176 else return g
177
178
179 -- we don't need to split proc points for the NCG, unless
180 -- tablesNextToCode is off. The latter is because we have no
181 -- label to put on info tables for basic blocks that are not
182 -- the entry point.
183 splitting_proc_points = hscTarget dflags /= HscAsm
184 || not (tablesNextToCode dflags)
185 || -- Note [inconsistent-pic-reg]
186 usingInconsistentPicReg
187 usingInconsistentPicReg = ( platformArch platform == ArchX86 ||
188 platformArch platform == ArchPPC
189 )
190 && platformOS platform == OSDarwin
191 && gopt Opt_PIC dflags
192
193 {- Note [inconsistent-pic-reg]
194
195 On x86/Darwin, PIC is implemented by inserting a sequence like
196
197 call 1f
198 1: popl %reg
199
200 at the proc entry point, and then referring to labels as offsets from
201 %reg. If we don't split proc points, then we could have many entry
202 points in a proc that would need this sequence, and each entry point
203 would then get a different value for %reg. If there are any join
204 points, then at the join point we don't have a consistent value for
205 %reg, so we don't know how to refer to labels.
206
207 Hence, on x86/Darwin, we have to split proc points, and then each proc
208 point will get its own PIC initialisation sequence.
209
210 The situation is the same for ppc/Darwin. We use essentially the same
211 sequence to load the program counter onto reg:
212
213 bcl 20,31,1f
214 1: mflr reg
215
216 This isn't an issue on x86/ELF, where the sequence is
217
218 call 1f
219 1: popl %reg
220 addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
221
222 so %reg always has a consistent value: the address of
223 _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
224
225 -}
226
227 {- Note [unreachable blocks]
228
229 The control-flow optimiser sometimes leaves unreachable blocks behind
230 containing junk code. If these blocks make it into the native code
231 generator then they trigger a register allocator panic because they
232 refer to undefined LocalRegs, so we must eliminate any unreachable
233 blocks before passing the code onwards.
234
235 -}
236
237 runUniqSM :: UniqSM a -> IO a
238 runUniqSM m = do
239 us <- mkSplitUniqSupply 'u'
240 return (initUs_ us m)
241
242
243 dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
244 dumpGraph dflags flag name g = do
245 when (gopt Opt_DoCmmLinting dflags) $ do_lint g
246 dumpWith dflags flag name g
247 where
248 do_lint g = case cmmLintGraph dflags g of
249 Just err -> do { fatalErrorMsg dflags err
250 ; ghcExit dflags 1
251 }
252 Nothing -> return ()
253
254 dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
255 dumpWith dflags flag txt g = do
256 -- ToDo: No easy way of say "dump all the cmm, *and* split
257 -- them into files." Also, -ddump-cmm doesn't play nicely
258 -- with -ddump-to-file, since the headers get omitted.
259 dumpIfSet_dyn dflags flag txt (ppr g)
260 when (not (dopt flag dflags)) $
261 dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g)
262