Fix -fPIC on OS X x86
[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 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 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 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
183 usingDarwinX86Pic = platformArch platform == ArchX86
184 && platformOS platform == OSDarwin
185 && gopt Opt_PIC dflags
186
187 runUniqSM :: UniqSM a -> IO a
188 runUniqSM m = do
189 us <- mkSplitUniqSupply 'u'
190 return (initUs_ us m)
191
192
193 dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
194 dumpGraph dflags flag name g = do
195 when (gopt Opt_DoCmmLinting dflags) $ do_lint g
196 dumpWith dflags flag name g
197 where
198 do_lint g = case cmmLintGraph dflags g of
199 Just err -> do { fatalErrorMsg dflags err
200 ; ghcExit dflags 1
201 }
202 Nothing -> return ()
203
204 dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
205 dumpWith dflags flag txt g = do
206 -- ToDo: No easy way of say "dump all the cmmz, *and* split
207 -- them into files." Also, -ddump-cmmz doesn't play nicely
208 -- with -ddump-to-file, since the headers get omitted.
209 dumpIfSet_dyn dflags flag txt (ppr g)
210 when (not (dopt flag dflags)) $
211 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
212