debug printing of the CAFEnv
[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 "toTops" #-} doSRTs 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)) $
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 l call_pps proc_points pp_map (CmmProc h l g)
118 dumps Opt_D_dump_cmmz_split "Post splitting" gs
119
120 ------------- Populate info tables with stack info -----------------
121 gs <- {-# SCC "setInfoTableStackMap" #-}
122 return $ map (setInfoTableStackMap stackmaps) gs
123 dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
124
125 ----------- Control-flow optimisations -----------------------------
126 gs <- {-# SCC "cmmCfgOpts(2)" #-}
127 return $ if optLevel dflags >= 1
128 then map (cmmCfgOptsProc splitting_proc_points) gs
129 else gs
130 dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
131
132 return (cafEnv, gs)
133
134 else do
135 -- attach info tables to return points
136 g <- return $ attachContInfoTables call_pps (CmmProc h l g)
137
138 ------------- Populate info tables with stack info -----------------
139 g <- {-# SCC "setInfoTableStackMap" #-}
140 return $ setInfoTableStackMap stackmaps g
141 dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
142
143 ----------- Control-flow optimisations -----------------------------
144 g <- {-# SCC "cmmCfgOpts(2)" #-}
145 return $ if optLevel dflags >= 1
146 then cmmCfgOptsProc splitting_proc_points g
147 else g
148 dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
149
150 return (cafEnv, [g])
151
152 where dflags = hsc_dflags hsc_env
153 dump = dumpGraph dflags
154 dump' = dumpWith dflags
155
156 dumps flag name
157 = mapM_ (dumpWith dflags flag name)
158
159 condPass flag pass g dumpflag dumpname =
160 if dopt flag dflags
161 then do
162 g <- return $ pass g
163 dump dumpflag dumpname g
164 return g
165 else return g
166
167
168 -- we don't need to split proc points for the NCG, unless
169 -- tablesNextToCode is off. The latter is because we have no
170 -- label to put on info tables for basic blocks that are not
171 -- the entry point.
172 splitting_proc_points = hscTarget dflags /= HscAsm
173 || not (tablesNextToCode dflags)
174
175 runUniqSM :: UniqSM a -> IO a
176 runUniqSM m = do
177 us <- mkSplitUniqSupply 'u'
178 return (initUs_ us m)
179
180
181 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
182 dumpGraph dflags flag name g = do
183 when (dopt Opt_DoCmmLinting dflags) $ do_lint g
184 dumpWith dflags flag name g
185 where
186 do_lint g = case cmmLintGraph g of
187 Just err -> do { fatalErrorMsg dflags err
188 ; ghcExit dflags 1
189 }
190 Nothing -> return ()
191
192 dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
193 dumpWith dflags flag txt g = do
194 -- ToDo: No easy way of say "dump all the cmmz, *and* split
195 -- them into files." Also, -ddump-cmmz doesn't play nicely
196 -- with -ddump-to-file, since the headers get omitted.
197 dumpIfSet_dyn dflags flag txt (ppr g)
198 when (not (dopt flag dflags)) $
199 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
200