2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CodeGen]{@CodeGen@: main module of the code generator}
6 This module says how things get going at the top level.
8 @codeGen@ is the interface to the outside world. The \tr{cgTop*}
9 functions drive the mangling of top-level bindings.
11 %************************************************************************
13 \subsection[codeGen-outside-interface]{The code generator's offering to the world}
15 %************************************************************************
18 module CodeGen ( codeGen ) where
20 #include "HsVersions.h"
22 -- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
23 -- import. Before, that wasn't the case, and CM therefore didn't
24 -- bother to compile it.
25 import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
28 import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo,
30 import CgClosure ( cgTopRhsClosure )
31 import CgCon ( cgTopRhsCon, cgTyCon )
32 import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
36 import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
37 import PprCmm ( pprCmms )
38 import MachOp ( wordRep, MachHint(..) )
41 import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
42 import DynFlags ( DynFlags(..), DynFlag(..), dopt )
43 import StaticFlags ( opt_SccProfilingOn )
45 import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons )
46 import CostCentre ( CollectedCCs )
47 import Id ( Id, idName, setIdName )
48 import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
49 import OccName ( mkLocalOcc )
50 import TyCon ( isDataTyCon )
51 import Module ( Module, mkModule )
52 import ErrUtils ( dumpIfSet_dyn, showPass )
53 import Panic ( assertPanic )
65 -> [Module] -- directly-imported modules
66 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
67 -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
70 codeGen dflags this_mod type_env foreign_stubs imported_mods
71 cost_centre_info stg_binds
73 { showPass dflags "CodeGen"
74 ; let way = buildTag dflags
75 mb_main_mod = mainModIs dflags
77 ; let tycons = typeEnvTyCons type_env
78 data_tycons = filter isDataTyCon tycons
81 -- ; mapM_ (\x -> seq x (return ())) data_tycons
83 ; code_stuff <- initC dflags this_mod $ do
84 { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
85 ; cmm_tycons <- mapM cgTyCon data_tycons
86 ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info
88 foreign_stubs imported_mods)
89 ; return (cmm_binds ++ concat cmm_tycons
90 ++ if opt_SccProfilingOn
91 #if defined(mingw32_HOST_OS)
97 -- Put datatype_stuff after code_stuff, because the
98 -- datatype closure table (for enumeration types) to
99 -- (say) PrelBase_True_closure, which is defined in
102 ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
104 ; return code_stuff }
107 %************************************************************************
109 \subsection[codegen-init]{Module initialisation code}
111 %************************************************************************
113 /* -----------------------------------------------------------------------------
114 Module initialisation
116 The module initialisation code looks like this, roughly:
119 JMP_(__stginit_Foo_1_p)
122 FN(__stginit_Foo_1_p) {
126 We have one version of the init code with a module version and the
127 'way' attached to it. The version number helps to catch cases
128 where modules are not compiled in dependency order before being
129 linked: if a module has been compiled since any modules which depend on
130 it, then the latter modules will refer to a different version in their
131 init blocks and a link error will ensue.
133 The 'way' suffix helps to catch cases where modules compiled in different
134 ways are linked together (eg. profiled and non-profiled).
136 We provide a plain, unadorned, version of the module init code
137 which just jumps to the version with the label and way attached. The
138 reason for this is that when using foreign exports, the caller of
139 startupHaskell() must supply the name of the init function for the "top"
140 module in the program, and we don't want to require that this name
141 has the version and way info appended to it.
142 -------------------------------------------------------------------------- */
144 We initialise the module tree by keeping a work-stack,
146 * that grows downward
147 * Sp points to the last occupied slot
153 -> String -- the "way"
154 -> CollectedCCs -- cost centre info
156 -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
160 mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
163 -- Allocate the static boolean that records if this
164 -- module has been registered already
165 ; emitData Data [CmmDataLabel moduleRegdLabel,
166 CmmStaticLit zeroCLit]
168 ; emitSimpleProc real_init_lbl $ do
169 { -- The return-code pops the work stack by
170 -- incrementing Sp, and then jumpd to the popped item
171 ret_blk <- forkLabelledCode $ stmtsC
172 [ CmmAssign spReg (cmmRegOffW spReg 1)
173 , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
175 ; init_blk <- forkLabelledCode $ do
176 { mod_init_code; stmtC (CmmBranch ret_blk) }
178 ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
180 ; stmtC (CmmBranch init_blk)
184 -- Make the "plain" procedure jump to the "real" init procedure
185 ; emitSimpleProc plain_init_lbl jump_to_init
187 -- When compiling the module in which the 'main' function lives,
188 -- (that is, this_mod == main_mod)
189 -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
190 -- RTS to invoke. We must consult the -main-is flag in case the
191 -- user specified a different function to Main.main
192 ; whenC (this_mod == main_mod)
193 (emitSimpleProc plain_main_init_lbl jump_to_init)
196 plain_init_lbl = mkPlainModuleInitLabel dflags this_mod
197 real_init_lbl = mkModuleInitLabel dflags this_mod way
198 plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN
200 jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
202 mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
204 main_mod = case mb_main_mod of
205 Just mod_name -> mkModule mod_name
208 -- Main refers to GHC.TopHandler.runIO, so make sure we call the
209 -- init function for GHC.TopHandler.
211 | this_mod == main_mod = [pREL_TOP_HANDLER]
215 { -- Set mod_reg to 1 to record that we've been here
216 stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
218 -- Now do local stuff
219 #if defined(mingw32_HOST_OS)
220 ; registerForeignExports foreign_stubs
222 ; initCostCentres cost_centre_info
223 ; mapCs (registerModuleImport dflags way)
224 (imported_mods++extra_imported_mods)
228 -----------------------
229 registerModuleImport :: DynFlags -> String -> Module -> Code
230 registerModuleImport dflags way mod
233 | otherwise -- Push the init procedure onto the work stack
234 = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
235 , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ]
237 -----------------------
238 registerForeignExports :: ForeignStubs -> Code
239 registerForeignExports NoStubs
241 registerForeignExports (ForeignStubs _ _ _ fe_bndrs)
242 = mapM_ mk_export_register fe_bndrs
244 mk_export_register bndr
245 = emitRtsCall SLIT("getStablePtr")
246 [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))),
252 Cost-centre profiling: Besides the usual stuff, we must produce
253 declarations for the cost-centres defined in this module;
255 (The local cost-centres involved in this are passed into the
259 initCostCentres :: CollectedCCs -> Code
260 -- Emit the declarations, and return code to register them
261 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
262 | not opt_SccProfilingOn = nopC
264 = do { mapM_ emitCostCentreDecl local_CCs
265 ; mapM_ emitCostCentreStackDecl singleton_CCSs
266 ; mapM_ emitRegisterCC local_CCs
267 ; mapM_ emitRegisterCCS singleton_CCSs
271 %************************************************************************
273 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
275 %************************************************************************
277 @cgTopBinding@ is only used for top-level bindings, since they need
278 to be allocated statically (not in the heap) and need to be labelled.
279 No unboxed bindings can happen at top level.
281 In the code below, the static bindings are accumulated in the
282 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
283 This is so that we can write the top level processing in a compositional
284 style, with the increasing static environment being plumbed as a state
288 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
289 cgTopBinding dflags (StgNonRec id rhs, srts)
290 = do { id' <- maybeExternaliseId dflags id
291 ; mapM_ (mkSRT dflags [id']) srts
292 ; (id,info) <- cgTopRhs id' rhs
293 ; addBindC id info -- Add the *un-externalised* Id to the envt,
294 -- so we find it when we look up occurrences
297 cgTopBinding dflags (StgRec pairs, srts)
298 = do { let (bndrs, rhss) = unzip pairs
299 ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
300 ; let pairs' = zip bndrs' rhss
301 ; mapM_ (mkSRT dflags bndrs') srts
302 ; _new_binds <- fixC (\ new_binds -> do
303 { addBindsC new_binds
304 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
307 mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code
308 mkSRT dflags these (id,[]) = nopC
309 mkSRT dflags these (id,ids)
310 = do { ids <- mapFCs remap ids
312 ; emitRODataLits (mkSRTLabel (idName id))
313 (map (CmmLabel . mkClosureLabel dflags . idName) ids)
316 -- Sigh, better map all the ids against the environment in
317 -- case they've been externalised (see maybeExternaliseId below).
318 remap id = case filter (==id) these of
319 (id':_) -> returnFC id'
320 [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
322 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
323 -- to enclose the listFCs in cgTopBinding, but that tickled the
324 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
326 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
327 -- The Id is passed along for setting up a binding...
328 -- It's already been externalised if necessary
330 cgTopRhs bndr (StgRhsCon cc con args)
331 = forkStatics (cgTopRhsCon bndr con args)
333 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
334 = ASSERT(null fvs) -- There should be no free variables
335 setSRTLabel (mkSRTLabel (idName bndr)) $
336 forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
340 %************************************************************************
342 \subsection{Stuff to support splitting}
344 %************************************************************************
346 If we're splitting the object, we need to externalise all the top-level names
347 (and then make sure we only use the externalised one in any C label we use
348 which refers to this name).
351 maybeExternaliseId :: DynFlags -> Id -> FCode Id
352 maybeExternaliseId dflags id
353 | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs
354 isInternalName name = do { mod <- moduleName
355 ; returnFC (setIdName id (externalise mod)) }
356 | otherwise = returnFC id
358 externalise mod = mkExternalName uniq mod new_occ Nothing loc
360 uniq = nameUnique name
361 new_occ = mkLocalOcc uniq (nameOccName name)
362 loc = nameSrcLoc name
363 -- We want to conjure up a name that can't clash with any
364 -- existing name. So we generate
366 -- where 243 is the unique.