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