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
57 -> IO [CmmZ] -- Output
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 --; mapM_ (mkSRT [id']) srts
108 ; (id,info) <- cgTopRhs id' rhs
109 ; addBindC id info -- Add the *un-externalised* Id to the envt,
110 -- so we find it when we look up occurrences
113 cgTopBinding dflags (StgRec pairs, _srts)
114 = do { let (bndrs, rhss) = unzip pairs
115 ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
116 ; let pairs' = zip bndrs' rhss
117 --; mapM_ (mkSRT bndrs') srts
118 ; fixC (\ new_binds -> do
119 { addBindsC new_binds
120 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
123 --mkSRT :: [Id] -> (Id,[Id]) -> FCode ()
124 --mkSRT these (id,ids)
127 -- = do { ids <- mapFCs remap ids
129 -- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id))
130 -- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
133 -- -- Sigh, better map all the ids against the environment in
134 -- -- case they've been externalised (see maybeExternaliseId below).
135 -- remap id = case filter (==id) these of
136 -- (id':_) -> returnFC id'
137 -- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
139 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
140 -- to enclose the listFCs in cgTopBinding, but that tickled the
141 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
143 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
144 -- The Id is passed along for setting up a binding...
145 -- It's already been externalised if necessary
147 cgTopRhs bndr (StgRhsCon _cc con args)
148 = forkStatics (cgTopRhsCon bndr con args)
150 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
151 = ASSERT(null fvs) -- There should be no free variables
152 setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
153 forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
157 ---------------------------------------------------------------
158 -- Module initialisation code
159 ---------------------------------------------------------------
161 {- The module initialisation code looks like this, roughly:
164 JMP_(__stginit_Foo_1_p)
167 FN(__stginit_Foo_1_p) {
171 We have one version of the init code with a module version and the
172 'way' attached to it. The version number helps to catch cases
173 where modules are not compiled in dependency order before being
174 linked: if a module has been compiled since any modules which depend on
175 it, then the latter modules will refer to a different version in their
176 init blocks and a link error will ensue.
178 The 'way' suffix helps to catch cases where modules compiled in different
179 ways are linked together (eg. profiled and non-profiled).
181 We provide a plain, unadorned, version of the module init code
182 which just jumps to the version with the label and way attached. The
183 reason for this is that when using foreign exports, the caller of
184 startupHaskell() must supply the name of the init function for the "top"
185 module in the program, and we don't want to require that this name
186 has the version and way info appended to it.
188 We initialise the module tree by keeping a work-stack,
190 * that grows downward
191 * Sp points to the last occupied slot
195 :: String -- the "way"
196 -> CollectedCCs -- cost centre info
198 -> Module -- name of the Main module
202 mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
203 = do { -- Allocate the static boolean that records if this
204 -- module has been registered already
205 emitData Data [CmmDataLabel moduleRegdLabel,
206 CmmStaticLit zeroCLit]
208 ; init_hpc <- initHpc this_mod hpc_info
209 ; init_prof <- initCostCentres cost_centre_info
211 -- We emit a recursive descent module search for all modules
212 -- and *choose* to chase it in :Main, below.
213 -- In this way, Hpc enabled modules can interact seamlessly with
214 -- not Hpc enabled moduled, provided Main is compiled with Hpc.
216 ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs
217 [ check_already_done retId
220 , catAGraphs $ map (registerImport way) all_imported_mods
222 -- Make the "plain" procedure jump to the "real" init procedure
223 ; emitSimpleProc plain_init_lbl jump_to_init
225 -- When compiling the module in which the 'main' function lives,
226 -- (that is, this_mod == main_mod)
227 -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
228 -- RTS to invoke. We must consult the -main-is flag in case the
229 -- user specified a different function to Main.main
231 -- Notice that the recursive descent is optional, depending on what options
235 ; whenC (this_mod == main_mod)
236 (emitSimpleProc plain_main_init_lbl rec_descent_init)
239 plain_init_lbl = mkPlainModuleInitLabel this_mod
240 real_init_lbl = mkModuleInitLabel this_mod way
241 plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
243 jump_to_init = mkJump (mkLblExpr real_init_lbl) []
246 -- Main refers to GHC.TopHandler.runIO, so make sure we call the
247 -- init function for GHC.TopHandler.
249 | this_mod == main_mod = [gHC_TOP_HANDLER]
251 all_imported_mods = imported_mods ++ extra_imported_mods
253 mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
254 check_already_done retId
255 = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
256 (mkLabel retId Nothing <*> mkReturn []) mkNop
257 <*> -- Set mod_reg to 1 to record that we've been here
258 mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
260 -- The return-code pops the work stack by
261 -- incrementing Sp, and then jumpd to the popped item
262 ret_code = mkAssign spReg (cmmRegOffW spReg 1)
263 <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) []
265 rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
269 -----------------------
270 registerImport :: String -> Module -> CmmAGraph
271 registerImport way mod
274 | otherwise -- Push the init procedure onto the work stack
275 = mkCmmCall init_lbl [] [] NoC_SRT
277 init_lbl = mkLblExpr $ mkModuleInitLabel mod way
281 ---------------------------------------------------------------
282 -- Generating static stuff for algebraic data types
283 ---------------------------------------------------------------
285 {- [These comments are rather out of date]
287 Macro Kind of constructor
288 CONST_INFO_TABLE@ Zero arity (no info -- compiler uses static closure)
289 CHARLIKE_INFO_TABLE Charlike (no info -- compiler indexes fixed array)
290 INTLIKE_INFO_TABLE Intlike; the one macro generates both info tbls
291 SPEC_INFO_TABLE SPECish, and bigger than or equal to MIN_UPD_SIZE
292 GEN_INFO_TABLE GENish (hence bigger than or equal to MIN_UPD_SIZE@)
294 Possible info tables for constructor con:
297 Used for dynamically let(rec)-bound occurrences of
298 the constructor, and for updates. For constructors
299 which are int-like, char-like or nullary, when GC occurs,
300 the closure tries to get rid of itself.
303 Static occurrences of the constructor macro: STATIC_INFO_TABLE.
305 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
306 it's place is taken by the top level defn of the constructor.
308 For charlike and intlike closures there is a fixed array of static
309 closures predeclared.
312 cgTyCon :: TyCon -> FCode [CmmZ] -- All constructors merged together
314 = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
316 -- Generate a table of static closures for an enumeration type
317 -- Put the table after the data constructor decls, because the
318 -- datatype closure table (for enumeration types)
319 -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
320 -- Note that the closure pointers are tagged.
322 -- N.B. comment says to put table after constructor decls, but
323 -- code puts it before --- NR 16 Aug 2007
324 ; extra <- cgEnumerationTyCon tycon
326 ; return (extra ++ constrs)
329 cgEnumerationTyCon :: TyCon -> FCode [CmmZ]
330 cgEnumerationTyCon tycon
331 | isEnumerationTyCon tycon
332 = do { tbl <- getCmm $
333 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
334 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
336 | con <- tyConDataCons tycon]
341 cgDataCon :: DataCon -> FCode ()
342 -- Generate the entry code, info tables, and (for niladic constructor)
343 -- the static closure, for a constructor.
346 -- To allow the debuggers, interpreters, etc to cope with
347 -- static data structures (ie those built at compile
348 -- time), we take care that info-table contains the
349 -- information we need.
350 (static_cl_info, _) = layOutStaticConstr data_con arg_reps
351 (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
353 emit_info cl_info ticky_code
354 = do { code_blks <- getCode (mk_code ticky_code)
355 ; emitClosureCodeAndInfoTable cl_info [] code_blks }
358 = -- NB: We don't set CC when entering data (WDP 94/06)
360 ; ldvEnter (CmmReg nodeReg)
361 ; tickyReturnOldCon (length arg_things)
362 ; emitReturn [cmmOffsetB (CmmReg nodeReg)
363 (tagForCon data_con)] }
364 -- The case continuation code expects a tagged pointer
366 arg_reps :: [(PrimRep, Type)]
367 arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
369 -- Dynamic closure code for non-nullary constructors only
370 ; whenC (not (isNullaryRepDataCon data_con))
371 (emit_info dyn_cl_info tickyEnterDynCon)
373 -- Dynamic-Closure first, to reduce forward references
374 ; emit_info static_cl_info tickyEnterStaticCon }
377 ---------------------------------------------------------------
378 -- Stuff to support splitting
379 ---------------------------------------------------------------
381 -- If we're splitting the object, we need to externalise all the
382 -- top-level names (and then make sure we only use the externalised
383 -- one in any C label we use which refers to this name).
385 maybeExternaliseId :: DynFlags -> Id -> FCode Id
386 maybeExternaliseId dflags id
387 | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs
388 isInternalName name = do { mod <- getModuleName
389 ; returnFC (setIdName id (externalise mod)) }
390 | otherwise = returnFC id
392 externalise mod = mkExternalName uniq mod new_occ loc
394 uniq = nameUnique name
395 new_occ = mkLocalOcc uniq (nameOccName name)
396 loc = nameSrcSpan name
397 -- We want to conjure up a name that can't clash with any
398 -- existing name. So we generate
400 -- where 243 is the unique.