Produce new-style Cmm from the Cmm parser
[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
29 -----------------------------------------------------------------------------
30 -- | Top level driver for C-- pipeline
31 -----------------------------------------------------------------------------
32
33 cmmPipeline :: HscEnv -- Compilation env including
34 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
35 -> TopSRT -- SRT table and accumulating list of compiled procs
36 -> CmmGroup -- Input C-- with Procedures
37 -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
38
39 cmmPipeline hsc_env topSRT prog =
40 do let dflags = hsc_dflags hsc_env
41
42 showPass dflags "CPSZ"
43
44 tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
45
46 (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
47 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
48
49 return (topSRT, cmms)
50
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 g <- {-# SCC "cmmCfgOpts(1)" #-}
64 return $ cmmCfgOptsProc splitting_proc_points proc
65 dump Opt_D_dump_cmmz_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_cmmz_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_cmmz 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 g
95 Opt_D_dump_cmmz_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_cmmz_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_cmmz_rewrite "Sink assignments (2)"
110
111 ------------- CAF analysis ----------------------------------------------
112 let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
113 dumpIfSet_dyn dflags Opt_D_dump_cmmz "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_cmmz_procmap "procpoint map" pp_map
121 gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
122 splitAtProcPoints dflags l call_pps proc_points pp_map
123 (CmmProc h l g)
124 dumps Opt_D_dump_cmmz_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_cmmz_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 dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
137
138 return (cafEnv, gs)
139
140 else do
141 -- attach info tables to return points
142 g <- return $ attachContInfoTables call_pps (CmmProc h l g)
143
144 ------------- Populate info tables with stack info -----------------
145 g <- {-# SCC "setInfoTableStackMap" #-}
146 return $ setInfoTableStackMap dflags stackmaps g
147 dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
148
149 ----------- Control-flow optimisations -----------------------------
150 g <- {-# SCC "cmmCfgOpts(2)" #-}
151 return $ if optLevel dflags >= 1
152 then cmmCfgOptsProc splitting_proc_points g
153 else g
154 dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
155
156 return (cafEnv, [g])
157
158 where dflags = hsc_dflags hsc_env
159 dump = dumpGraph dflags
160 dump' = dumpWith dflags
161
162 dumps flag name
163 = mapM_ (dumpWith dflags flag name)
164
165 condPass flag pass g dumpflag dumpname =
166 if dopt flag dflags
167 then do
168 g <- return $ pass g
169 dump dumpflag dumpname g
170 return g
171 else return g
172
173
174 -- we don't need to split proc points for the NCG, unless
175 -- tablesNextToCode is off. The latter is because we have no
176 -- label to put on info tables for basic blocks that are not
177 -- the entry point.
178 splitting_proc_points = hscTarget dflags /= HscAsm
179 || not (tablesNextToCode dflags)
180
181 runUniqSM :: UniqSM a -> IO a
182 runUniqSM m = do
183 us <- mkSplitUniqSupply 'u'
184 return (initUs_ us m)
185
186
187 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
188 dumpGraph dflags flag name g = do
189 when (dopt Opt_DoCmmLinting dflags) $ do_lint g
190 dumpWith dflags flag name g
191 where
192 do_lint g = case cmmLintGraph dflags g of
193 Just err -> do { fatalErrorMsg dflags err
194 ; ghcExit dflags 1
195 }
196 Nothing -> return ()
197
198 dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
199 dumpWith dflags flag txt g = do
200 -- ToDo: No easy way of say "dump all the cmmz, *and* split
201 -- them into files." Also, -ddump-cmmz doesn't play nicely
202 -- with -ddump-to-file, since the headers get omitted.
203 dumpIfSet_dyn dflags flag txt (ppr g)
204 when (not (dopt flag dflags)) $
205 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
206