Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / codeGen / StgCmm.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmm ( codeGen ) where
10
11 #define FAST_STRING_NOT_NEEDED
12 #include "HsVersions.h"
13
14 import StgCmmProf
15 import StgCmmMonad
16 import StgCmmEnv
17 import StgCmmBind
18 import StgCmmCon
19 import StgCmmLayout
20 import StgCmmUtils
21 import StgCmmClosure
22 import StgCmmHpc
23 import StgCmmTicky
24
25 import Cmm
26 import CLabel
27 import PprCmm
28
29 import StgSyn
30 import DynFlags
31
32 import HscTypes
33 import CostCentre
34 import Id
35 import IdInfo
36 import Type
37 import DataCon
38 import Name
39 import TyCon
40 import Module
41 import ErrUtils
42 import Outputable
43
44 codeGen :: DynFlags
45 -> Module
46 -> [TyCon]
47 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
48 -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
49 -> HpcInfo
50 -> IO [CmmPgm] -- Output
51
52 codeGen dflags this_mod data_tycons
53 cost_centre_info stg_binds hpc_info
54 = do { showPass dflags "New CodeGen"
55
56 -- Why?
57 -- ; mapM_ (\x -> seq x (return ())) data_tycons
58
59 ; code_stuff <- initC dflags this_mod $ do
60 { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
61 ; cmm_tycons <- mapM cgTyCon data_tycons
62 ; cmm_init <- getCmm (mkModuleInit cost_centre_info
63 this_mod hpc_info)
64 ; return (cmm_init : cmm_binds ++ cmm_tycons)
65 }
66 -- Put datatype_stuff after code_stuff, because the
67 -- datatype closure table (for enumeration types) to
68 -- (say) PrelBase_True_closure, which is defined in
69 -- code_stuff
70
71 -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
72 -- possible for object splitting to split up the
73 -- pieces later.
74
75 -- Note [codegen-split-init] the cmm_init block must
76 -- come FIRST. This is because when -split-objs is on
77 -- we need to combine this block with its
78 -- initialisation routines; see Note
79 -- [pipeline-split-init].
80
81 ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff)
82
83 ; return code_stuff }
84
85
86 ---------------------------------------------------------------
87 -- Top-level bindings
88 ---------------------------------------------------------------
89
90 {- 'cgTopBinding' is only used for top-level bindings, since they need
91 to be allocated statically (not in the heap) and need to be labelled.
92 No unboxed bindings can happen at top level.
93
94 In the code below, the static bindings are accumulated in the
95 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
96 This is so that we can write the top level processing in a compositional
97 style, with the increasing static environment being plumbed as a state
98 variable. -}
99
100 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
101 cgTopBinding dflags (StgNonRec id rhs, _srts)
102 = do { id' <- maybeExternaliseId dflags id
103 ; info <- cgTopRhs id' rhs
104 ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
105 -- so we find it when we look up occurrences
106 }
107
108 cgTopBinding dflags (StgRec pairs, _srts)
109 = do { let (bndrs, rhss) = unzip pairs
110 ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
111 ; let pairs' = zip bndrs' rhss
112 ; fixC_(\ new_binds -> do
113 { addBindsC new_binds
114 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
115 ; return () }
116
117 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
118 -- to enclose the listFCs in cgTopBinding, but that tickled the
119 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
120
121 cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
122 -- The Id is passed along for setting up a binding...
123 -- It's already been externalised if necessary
124
125 cgTopRhs bndr (StgRhsCon _cc con args)
126 = forkStatics (cgTopRhsCon bndr con args)
127
128 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
129 = ASSERT(null fvs) -- There should be no free variables
130 setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
131 forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
132
133
134 ---------------------------------------------------------------
135 -- Module initialisation code
136 ---------------------------------------------------------------
137
138 {- The module initialisation code looks like this, roughly:
139
140 FN(__stginit_Foo) {
141 JMP_(__stginit_Foo_1_p)
142 }
143
144 FN(__stginit_Foo_1_p) {
145 ...
146 }
147
148 We have one version of the init code with a module version and the
149 'way' attached to it. The version number helps to catch cases
150 where modules are not compiled in dependency order before being
151 linked: if a module has been compiled since any modules which depend on
152 it, then the latter modules will refer to a different version in their
153 init blocks and a link error will ensue.
154
155 The 'way' suffix helps to catch cases where modules compiled in different
156 ways are linked together (eg. profiled and non-profiled).
157
158 We provide a plain, unadorned, version of the module init code
159 which just jumps to the version with the label and way attached. The
160 reason for this is that when using foreign exports, the caller of
161 startupHaskell() must supply the name of the init function for the "top"
162 module in the program, and we don't want to require that this name
163 has the version and way info appended to it.
164
165 We initialise the module tree by keeping a work-stack,
166 * pointed to by Sp
167 * that grows downward
168 * Sp points to the last occupied slot
169 -}
170
171 mkModuleInit
172 :: CollectedCCs -- cost centre info
173 -> Module
174 -> HpcInfo
175 -> FCode ()
176
177 mkModuleInit cost_centre_info this_mod hpc_info
178 = do { initHpc this_mod hpc_info
179 ; initCostCentres cost_centre_info
180 -- For backwards compatibility: user code may refer to this
181 -- label for calling hs_add_root().
182 ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) []))
183 }
184
185 ---------------------------------------------------------------
186 -- Generating static stuff for algebraic data types
187 ---------------------------------------------------------------
188
189 {- [These comments are rather out of date]
190
191 Macro Kind of constructor
192 CONST_INFO_TABLE@ Zero arity (no info -- compiler uses static closure)
193 CHARLIKE_INFO_TABLE Charlike (no info -- compiler indexes fixed array)
194 INTLIKE_INFO_TABLE Intlike; the one macro generates both info tbls
195 SPEC_INFO_TABLE SPECish, and bigger than or equal to MIN_UPD_SIZE
196 GEN_INFO_TABLE GENish (hence bigger than or equal to MIN_UPD_SIZE@)
197
198 Possible info tables for constructor con:
199
200 * _con_info:
201 Used for dynamically let(rec)-bound occurrences of
202 the constructor, and for updates. For constructors
203 which are int-like, char-like or nullary, when GC occurs,
204 the closure tries to get rid of itself.
205
206 * _static_info:
207 Static occurrences of the constructor macro: STATIC_INFO_TABLE.
208
209 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
210 it's place is taken by the top level defn of the constructor.
211
212 For charlike and intlike closures there is a fixed array of static
213 closures predeclared.
214 -}
215
216 cgTyCon :: TyCon -> FCode CmmPgm -- All constructors merged together
217 cgTyCon tycon
218 = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
219
220 -- Generate a table of static closures for an enumeration type
221 -- Put the table after the data constructor decls, because the
222 -- datatype closure table (for enumeration types)
223 -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
224 -- Note that the closure pointers are tagged.
225
226 -- N.B. comment says to put table after constructor decls, but
227 -- code puts it before --- NR 16 Aug 2007
228 ; extra <- cgEnumerationTyCon tycon
229
230 ; return (concat (extra ++ constrs))
231 }
232
233 cgEnumerationTyCon :: TyCon -> FCode [CmmPgm]
234 cgEnumerationTyCon tycon
235 | isEnumerationTyCon tycon
236 = do { tbl <- getCmm $
237 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
238 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
239 (tagForCon con)
240 | con <- tyConDataCons tycon]
241 ; return [tbl] }
242 | otherwise
243 = return []
244
245 cgDataCon :: DataCon -> FCode ()
246 -- Generate the entry code, info tables, and (for niladic constructor)
247 -- the static closure, for a constructor.
248 cgDataCon data_con
249 = do { let
250 -- To allow the debuggers, interpreters, etc to cope with
251 -- static data structures (ie those built at compile
252 -- time), we take care that info-table contains the
253 -- information we need.
254 static_cl_info = mkConInfo True no_cafs data_con tot_wds ptr_wds
255 dyn_cl_info = mkConInfo False NoCafRefs data_con tot_wds ptr_wds
256 no_cafs = pprPanic "cgDataCon: CAF field should not be reqd" (ppr data_con)
257
258 (tot_wds, -- #ptr_wds + #nonptr_wds
259 ptr_wds, -- #ptr_wds
260 arg_things) = mkVirtConstrOffsets arg_reps
261
262 emit_info cl_info ticky_code
263 = emitClosureAndInfoTable cl_info NativeDirectCall []
264 $ mk_code ticky_code
265
266 mk_code ticky_code
267 = -- NB: We don't set CC when entering data (WDP 94/06)
268 do { _ <- ticky_code
269 ; ldvEnter (CmmReg nodeReg)
270 ; tickyReturnOldCon (length arg_things)
271 ; emitReturn [cmmOffsetB (CmmReg nodeReg)
272 (tagForCon data_con)] }
273 -- The case continuation code expects a tagged pointer
274
275 arg_reps :: [(PrimRep, Type)]
276 arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
277
278 -- Dynamic closure code for non-nullary constructors only
279 ; whenC (not (isNullaryRepDataCon data_con))
280 (emit_info dyn_cl_info tickyEnterDynCon)
281
282 -- Dynamic-Closure first, to reduce forward references
283 ; emit_info static_cl_info tickyEnterStaticCon }
284
285
286 ---------------------------------------------------------------
287 -- Stuff to support splitting
288 ---------------------------------------------------------------
289
290 -- If we're splitting the object, we need to externalise all the
291 -- top-level names (and then make sure we only use the externalised
292 -- one in any C label we use which refers to this name).
293
294 maybeExternaliseId :: DynFlags -> Id -> FCode Id
295 maybeExternaliseId dflags id
296 | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs
297 isInternalName name = do { mod <- getModuleName
298 ; returnFC (setIdName id (externalise mod)) }
299 | otherwise = returnFC id
300 where
301 externalise mod = mkExternalName uniq mod new_occ loc
302 name = idName id
303 uniq = nameUnique name
304 new_occ = mkLocalOcc uniq (nameOccName name)
305 loc = nameSrcSpan name
306 -- We want to conjure up a name that can't clash with any
307 -- existing name. So we generate
308 -- Mod_$L243foo
309 -- where 243 is the unique.