5fca9e716479a9b06cc78b873a21a42b25e236fa
[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 (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
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 g <- {-# SCC "cmmCfgOpts(1)" #-}
64 return $ cmmCfgOpts splitting_proc_points g
65 dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
66
67 ----------- Eliminate common blocks -------------------------------------
68 g <- {-# SCC "elimCommonBlocks" #-}
69 condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
70 Opt_D_dump_cmmz_cbe "Post common block elimination"
71
72 -- Any work storing block Labels must be performed _after_
73 -- elimCommonBlocks
74
75 ----------- Proc points -------------------------------------------------
76 let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
77 proc_points <-
78 if splitting_proc_points
79 then {-# SCC "minimalProcPointSet" #-} runUniqSM $
80 minimalProcPointSet (targetPlatform dflags) call_pps g
81 else
82 return call_pps
83
84 let noncall_pps = proc_points `setDifference` call_pps
85 when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
86 pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
87
88 ----------- Sink and inline assignments *before* stack layout -----------
89 {- Maybe enable this later
90 g <- {-# SCC "sink1" #-}
91 condPass Opt_CmmSink cmmSink g
92 Opt_D_dump_cmmz_rewrite "Sink assignments (1)"
93 -}
94
95 ----------- Layout the stack and manifest Sp ----------------------------
96 (g, stackmaps) <-
97 {-# SCC "layoutStack" #-}
98 runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
99 dump Opt_D_dump_cmmz_sp "Layout Stack" g
100
101 ----------- Sink and inline assignments *after* stack layout ------------
102 g <- {-# SCC "sink2" #-}
103 condPass Opt_CmmSink (cmmSink dflags) g
104 Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
105
106 ------------- CAF analysis ----------------------------------------------
107 let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
108 dumpIfSet_dyn dflags Opt_D_dump_cmmz "CAFEnv" (ppr cafEnv)
109
110 if splitting_proc_points
111 then do
112 ------------- Split into separate procedures -----------------------
113 pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $
114 procPointAnalysis proc_points g
115 dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
116 gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
117 splitAtProcPoints dflags l call_pps proc_points pp_map
118 (CmmProc h l g)
119 dumps Opt_D_dump_cmmz_split "Post splitting" gs
120
121 ------------- Populate info tables with stack info -----------------
122 gs <- {-# SCC "setInfoTableStackMap" #-}
123 return $ map (setInfoTableStackMap dflags stackmaps) gs
124 dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
125
126 ----------- Control-flow optimisations -----------------------------
127 gs <- {-# SCC "cmmCfgOpts(2)" #-}
128 return $ if optLevel dflags >= 1
129 then map (cmmCfgOptsProc splitting_proc_points) gs
130 else gs
131 dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
132
133 return (cafEnv, gs)
134
135 else do
136 -- attach info tables to return points
137 g <- return $ attachContInfoTables call_pps (CmmProc h l g)
138
139 ------------- Populate info tables with stack info -----------------
140 g <- {-# SCC "setInfoTableStackMap" #-}
141 return $ setInfoTableStackMap dflags stackmaps g
142 dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
143
144 ----------- Control-flow optimisations -----------------------------
145 g <- {-# SCC "cmmCfgOpts(2)" #-}
146 return $ if optLevel dflags >= 1
147 then cmmCfgOptsProc splitting_proc_points g
148 else g
149 dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
150
151 return (cafEnv, [g])
152
153 where dflags = hsc_dflags hsc_env
154 dump = dumpGraph dflags
155 dump' = dumpWith dflags
156
157 dumps flag name
158 = mapM_ (dumpWith dflags flag name)
159
160 condPass flag pass g dumpflag dumpname =
161 if dopt flag dflags
162 then do
163 g <- return $ pass g
164 dump dumpflag dumpname g
165 return g
166 else return g
167
168
169 -- we don't need to split proc points for the NCG, unless
170 -- tablesNextToCode is off. The latter is because we have no
171 -- label to put on info tables for basic blocks that are not
172 -- the entry point.
173 splitting_proc_points = hscTarget dflags /= HscAsm
174 || not (tablesNextToCode dflags)
175
176 runUniqSM :: UniqSM a -> IO a
177 runUniqSM m = do
178 us <- mkSplitUniqSupply 'u'
179 return (initUs_ us m)
180
181
182 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
183 dumpGraph dflags flag name g = do
184 when (dopt Opt_DoCmmLinting dflags) $ do_lint g
185 dumpWith dflags flag name g
186 where
187 do_lint g = case cmmLintGraph dflags g of
188 Just err -> do { fatalErrorMsg dflags err
189 ; ghcExit dflags 1
190 }
191 Nothing -> return ()
192
193 dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
194 dumpWith dflags flag txt g = do
195 -- ToDo: No easy way of say "dump all the cmmz, *and* split
196 -- them into files." Also, -ddump-cmmz doesn't play nicely
197 -- with -ddump-to-file, since the headers get omitted.
198 dumpIfSet_dyn dflags flag txt (ppr g)
199 when (not (dopt flag dflags)) $
200 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
201