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