Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc
[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 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
49
50 return (topSRT, cmms)
51
52
53
54 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
55 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
56 cpsTop hsc_env proc =
57 do
58 ----------- Control-flow optimisations ----------------------------------
59
60 -- The first round of control-flow optimisation speeds up the
61 -- later passes by removing lots of empty blocks, so we do it
62 -- even when optimisation isn't turned on.
63 --
64 CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
65 return $ cmmCfgOptsProc splitting_proc_points proc
66 dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
67
68 let !TopInfo {stack_info=StackInfo { arg_space = entry_off
69 , do_layout = do_layout }} = h
70
71 ----------- Eliminate common blocks -------------------------------------
72 g <- {-# SCC "elimCommonBlocks" #-}
73 condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
74 Opt_D_dump_cmmz_cbe "Post common block elimination"
75
76 -- Any work storing block Labels must be performed _after_
77 -- elimCommonBlocks
78
79 ----------- Proc points -------------------------------------------------
80 let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
81 proc_points <-
82 if splitting_proc_points
83 then {-# SCC "minimalProcPointSet" #-} runUniqSM $
84 minimalProcPointSet (targetPlatform dflags) call_pps g
85 else
86 return call_pps
87
88 let noncall_pps = proc_points `setDifference` call_pps
89 when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
90 pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
91
92 ----------- Sink and inline assignments *before* stack layout -----------
93 {- Maybe enable this later
94 g <- {-# SCC "sink1" #-}
95 condPass Opt_CmmSink cmmSink g
96 Opt_D_dump_cmmz_rewrite "Sink assignments (1)"
97 -}
98
99 ----------- Layout the stack and manifest Sp ----------------------------
100 (g, stackmaps) <-
101 {-# SCC "layoutStack" #-}
102 if do_layout
103 then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
104 else return (g, mapEmpty)
105 dump Opt_D_dump_cmmz_sp "Layout Stack" g
106
107 ----------- Sink and inline assignments *after* stack layout ------------
108 g <- {-# SCC "sink2" #-}
109 condPass Opt_CmmSink (cmmSink dflags) g
110 Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
111
112 ------------- CAF analysis ----------------------------------------------
113 let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
114 dumpIfSet_dyn dflags Opt_D_dump_cmmz "CAFEnv" (ppr cafEnv)
115
116 if splitting_proc_points
117 then do
118 ------------- Split into separate procedures -----------------------
119 pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $
120 procPointAnalysis proc_points g
121 dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
122 gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
123 splitAtProcPoints dflags l call_pps proc_points pp_map
124 (CmmProc h l v g)
125 dumps Opt_D_dump_cmmz_split "Post splitting" gs
126
127 ------------- Populate info tables with stack info -----------------
128 gs <- {-# SCC "setInfoTableStackMap" #-}
129 return $ map (setInfoTableStackMap dflags stackmaps) gs
130 dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
131
132 ----------- Control-flow optimisations -----------------------------
133 gs <- {-# SCC "cmmCfgOpts(2)" #-}
134 return $ if optLevel dflags >= 1
135 then map (cmmCfgOptsProc splitting_proc_points) gs
136 else gs
137 dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
138
139 return (cafEnv, gs)
140
141 else do
142 -- attach info tables to return points
143 g <- return $ attachContInfoTables call_pps (CmmProc h l v g)
144
145 ------------- Populate info tables with stack info -----------------
146 g <- {-# SCC "setInfoTableStackMap" #-}
147 return $ setInfoTableStackMap dflags stackmaps g
148 dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
149
150 ----------- Control-flow optimisations -----------------------------
151 g <- {-# SCC "cmmCfgOpts(2)" #-}
152 return $ if optLevel dflags >= 1
153 then cmmCfgOptsProc splitting_proc_points g
154 else g
155 dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
156
157 return (cafEnv, [g])
158
159 where dflags = hsc_dflags hsc_env
160 platform = targetPlatform dflags
161 dump = dumpGraph dflags
162 dump' = dumpWith dflags
163
164 dumps flag name
165 = mapM_ (dumpWith dflags flag name)
166
167 condPass flag pass g dumpflag dumpname =
168 if gopt flag dflags
169 then do
170 g <- return $ pass g
171 dump dumpflag dumpname g
172 return g
173 else return g
174
175
176 -- we don't need to split proc points for the NCG, unless
177 -- tablesNextToCode is off. The latter is because we have no
178 -- label to put on info tables for basic blocks that are not
179 -- the entry point.
180 splitting_proc_points = hscTarget dflags /= HscAsm
181 || not (tablesNextToCode dflags)
182 || usingDarwinX86Pic -- Note [darwin-x86-pic]
183 usingDarwinX86Pic = platformArch platform == ArchX86
184 && platformOS platform == OSDarwin
185 && gopt Opt_PIC dflags
186
187 {- Note [darwin-x86-pic]
188
189 On x86/Darwin, PIC is implemented by inserting a sequence like
190
191 call 1f
192 1: popl %reg
193
194 at the proc entry point, and then referring to labels as offsets from
195 %reg. If we don't split proc points, then we could have many entry
196 points in a proc that would need this sequence, and each entry point
197 would then get a different value for %reg. If there are any join
198 points, then at the join point we don't have a consistent value for
199 %reg, so we don't know how to refer to labels.
200
201 Hence, on x86/Darwin, we have to split proc points, and then each proc
202 point will get its own PIC initialisation sequence.
203
204 This isn't an issue on x86/ELF, where the sequence is
205
206 call 1f
207 1: popl %reg
208 addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
209
210 so %reg always has a consistent value: the address of
211 _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
212
213 -}
214
215
216
217 runUniqSM :: UniqSM a -> IO a
218 runUniqSM m = do
219 us <- mkSplitUniqSupply 'u'
220 return (initUs_ us m)
221
222
223 dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
224 dumpGraph dflags flag name g = do
225 when (gopt Opt_DoCmmLinting dflags) $ do_lint g
226 dumpWith dflags flag name g
227 where
228 do_lint g = case cmmLintGraph dflags g of
229 Just err -> do { fatalErrorMsg dflags err
230 ; ghcExit dflags 1
231 }
232 Nothing -> return ()
233
234 dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
235 dumpWith dflags flag txt g = do
236 -- ToDo: No easy way of say "dump all the cmmz, *and* split
237 -- them into files." Also, -ddump-cmmz doesn't play nicely
238 -- with -ddump-to-file, since the headers get omitted.
239 dumpIfSet_dyn dflags flag txt (ppr g)
240 when (not (dopt flag dflags)) $
241 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
242