1 -----------------------------------------------------------------------------
3 -- Stg to C-- code generation
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
9 module StgCmm ( codeGen ) where
11 #define FAST_STRING_NOT_NEEDED
12 #include "HsVersions.h"
53 -> [Module] -- Directly-imported modules
54 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
55 -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
59 codeGen dflags this_mod data_tycons imported_mods
60 cost_centre_info stg_binds hpc_info
61 = do { showPass dflags "New CodeGen"
62 ; let way = buildTag dflags
63 main_mod = mainModIs dflags
66 -- ; mapM_ (\x -> seq x (return ())) data_tycons
68 ; code_stuff <- initC dflags this_mod $ do
69 { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
70 ; cmm_tycons <- mapM cgTyCon data_tycons
71 ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
73 imported_mods hpc_info)
74 ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
76 -- Put datatype_stuff after code_stuff, because the
77 -- datatype closure table (for enumeration types) to
78 -- (say) PrelBase_True_closure, which is defined in
81 -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
82 -- possible for object splitting to split up the
85 ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
90 ---------------------------------------------------------------
92 ---------------------------------------------------------------
94 {- 'cgTopBinding' is only used for top-level bindings, since they need
95 to be allocated statically (not in the heap) and need to be labelled.
96 No unboxed bindings can happen at top level.
98 In the code below, the static bindings are accumulated in the
99 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
100 This is so that we can write the top level processing in a compositional
101 style, with the increasing static environment being plumbed as a state
104 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
105 cgTopBinding dflags (StgNonRec id rhs, _srts)
106 = do { id' <- maybeExternaliseId dflags id
107 ; info <- cgTopRhs id' rhs
108 ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
109 -- so we find it when we look up occurrences
112 cgTopBinding dflags (StgRec pairs, _srts)
113 = do { let (bndrs, rhss) = unzip pairs
114 ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
115 ; let pairs' = zip bndrs' rhss
116 ; fixC_(\ new_binds -> do
117 { addBindsC new_binds
118 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
121 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
122 -- to enclose the listFCs in cgTopBinding, but that tickled the
123 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
125 cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
126 -- The Id is passed along for setting up a binding...
127 -- It's already been externalised if necessary
129 cgTopRhs bndr (StgRhsCon _cc con args)
130 = forkStatics (cgTopRhsCon bndr con args)
132 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
133 = ASSERT(null fvs) -- There should be no free variables
134 setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
135 forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
138 ---------------------------------------------------------------
139 -- Module initialisation code
140 ---------------------------------------------------------------
142 {- The module initialisation code looks like this, roughly:
145 JMP_(__stginit_Foo_1_p)
148 FN(__stginit_Foo_1_p) {
152 We have one version of the init code with a module version and the
153 'way' attached to it. The version number helps to catch cases
154 where modules are not compiled in dependency order before being
155 linked: if a module has been compiled since any modules which depend on
156 it, then the latter modules will refer to a different version in their
157 init blocks and a link error will ensue.
159 The 'way' suffix helps to catch cases where modules compiled in different
160 ways are linked together (eg. profiled and non-profiled).
162 We provide a plain, unadorned, version of the module init code
163 which just jumps to the version with the label and way attached. The
164 reason for this is that when using foreign exports, the caller of
165 startupHaskell() must supply the name of the init function for the "top"
166 module in the program, and we don't want to require that this name
167 has the version and way info appended to it.
169 We initialise the module tree by keeping a work-stack,
171 * that grows downward
172 * Sp points to the last occupied slot
176 :: String -- the "way"
177 -> CollectedCCs -- cost centre info
179 -> Module -- name of the Main module
183 mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
184 = do { -- Allocate the static boolean that records if this
185 -- module has been registered already
186 emitData Data [CmmDataLabel moduleRegdLabel,
187 CmmStaticLit zeroCLit]
189 ; init_hpc <- initHpc this_mod hpc_info
190 ; init_prof <- initCostCentres cost_centre_info
192 -- We emit a recursive descent module search for all modules
193 -- and *choose* to chase it in :Main, below.
194 -- In this way, Hpc enabled modules can interact seamlessly with
195 -- not Hpc enabled moduled, provided Main is compiled with Hpc.
197 ; updfr_sz <- getUpdFrameOff
198 ; tail <- getCode (pushUpdateFrame imports
199 (do updfr_sz' <- getUpdFrameOff
200 emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
201 ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
202 [ check_already_done retId updfr_sz
206 -- Make the "plain" procedure jump to the "real" init procedure
207 ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
209 -- When compiling the module in which the 'main' function lives,
210 -- (that is, this_mod == main_mod)
211 -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
212 -- RTS to invoke. We must consult the -main-is flag in case the
213 -- user specified a different function to Main.main
215 -- Notice that the recursive descent is optional, depending on what options
219 ; whenC (this_mod == main_mod)
220 (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
223 plain_init_lbl = mkPlainModuleInitLabel this_mod
224 real_init_lbl = mkModuleInitLabel this_mod way
225 plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
227 jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
230 -- Main refers to GHC.TopHandler.runIO, so make sure we call the
231 -- init function for GHC.TopHandler.
233 | this_mod == main_mod = [gHC_TOP_HANDLER]
235 all_imported_mods = imported_mods ++ extra_imported_mods
236 imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
237 (filter (gHC_PRIM /=) all_imported_mods)
239 mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
240 check_already_done retId updfr_sz
241 = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
242 (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
243 <*> -- Set mod_reg to 1 to record that we've been here
244 mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
246 -- The return-code pops the work stack by
247 -- incrementing Sp, and then jumps to the popped item
248 ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
249 ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
250 -- mkAssign spReg (cmmRegOffW spReg 1) <*>
251 -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
253 pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
255 rec_descent_init updfr_sz =
256 if opt_SccProfilingOn || isHpcUsed hpc_info
257 then jump_to_init updfr_sz
258 else ret_code updfr_sz
260 ---------------------------------------------------------------
261 -- Generating static stuff for algebraic data types
262 ---------------------------------------------------------------
264 {- [These comments are rather out of date]
266 Macro Kind of constructor
267 CONST_INFO_TABLE@ Zero arity (no info -- compiler uses static closure)
268 CHARLIKE_INFO_TABLE Charlike (no info -- compiler indexes fixed array)
269 INTLIKE_INFO_TABLE Intlike; the one macro generates both info tbls
270 SPEC_INFO_TABLE SPECish, and bigger than or equal to MIN_UPD_SIZE
271 GEN_INFO_TABLE GENish (hence bigger than or equal to MIN_UPD_SIZE@)
273 Possible info tables for constructor con:
276 Used for dynamically let(rec)-bound occurrences of
277 the constructor, and for updates. For constructors
278 which are int-like, char-like or nullary, when GC occurs,
279 the closure tries to get rid of itself.
282 Static occurrences of the constructor macro: STATIC_INFO_TABLE.
284 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
285 it's place is taken by the top level defn of the constructor.
287 For charlike and intlike closures there is a fixed array of static
288 closures predeclared.
291 cgTyCon :: TyCon -> FCode [Cmm] -- All constructors merged together
293 = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
295 -- Generate a table of static closures for an enumeration type
296 -- Put the table after the data constructor decls, because the
297 -- datatype closure table (for enumeration types)
298 -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
299 -- Note that the closure pointers are tagged.
301 -- N.B. comment says to put table after constructor decls, but
302 -- code puts it before --- NR 16 Aug 2007
303 ; extra <- cgEnumerationTyCon tycon
305 ; return (extra ++ constrs)
308 cgEnumerationTyCon :: TyCon -> FCode [Cmm]
309 cgEnumerationTyCon tycon
310 | isEnumerationTyCon tycon
311 = do { tbl <- getCmm $
312 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
313 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
315 | con <- tyConDataCons tycon]
320 cgDataCon :: DataCon -> FCode ()
321 -- Generate the entry code, info tables, and (for niladic constructor)
322 -- the static closure, for a constructor.
325 -- To allow the debuggers, interpreters, etc to cope with
326 -- static data structures (ie those built at compile
327 -- time), we take care that info-table contains the
328 -- information we need.
329 (static_cl_info, _) = layOutStaticConstr data_con arg_reps
330 (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
332 emit_info cl_info ticky_code
333 = emitClosureAndInfoTable cl_info NativeDirectCall []
337 = -- NB: We don't set CC when entering data (WDP 94/06)
339 ; ldvEnter (CmmReg nodeReg)
340 ; tickyReturnOldCon (length arg_things)
341 ; emitReturn [cmmOffsetB (CmmReg nodeReg)
342 (tagForCon data_con)] }
343 -- The case continuation code expects a tagged pointer
345 arg_reps :: [(PrimRep, Type)]
346 arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
348 -- Dynamic closure code for non-nullary constructors only
349 ; whenC (not (isNullaryRepDataCon data_con))
350 (emit_info dyn_cl_info tickyEnterDynCon)
352 -- Dynamic-Closure first, to reduce forward references
353 ; emit_info static_cl_info tickyEnterStaticCon }
356 ---------------------------------------------------------------
357 -- Stuff to support splitting
358 ---------------------------------------------------------------
360 -- If we're splitting the object, we need to externalise all the
361 -- top-level names (and then make sure we only use the externalised
362 -- one in any C label we use which refers to this name).
364 maybeExternaliseId :: DynFlags -> Id -> FCode Id
365 maybeExternaliseId dflags id
366 | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs
367 isInternalName name = do { mod <- getModuleName
368 ; returnFC (setIdName id (externalise mod)) }
369 | otherwise = returnFC id
371 externalise mod = mkExternalName uniq mod new_occ loc
373 uniq = nameUnique name
374 new_occ = mkLocalOcc uniq (nameOccName name)
375 loc = nameSrcSpan name
376 -- We want to conjure up a name that can't clash with any
377 -- existing name. So we generate
379 -- where 243 is the unique.