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"
25 import CLabel ( CLabel, mkSRTLabel, mkClosureLabel )
27 import PprAbsC ( dumpRealC )
28 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, flattenAbsC )
29 import CgBindery ( CgIdInfo, addBindC, addBindsC )
30 import CgClosure ( cgTopRhsClosure )
31 import CgCon ( cgTopRhsCon )
32 import CgConTbls ( genStaticConBits )
33 import ClosureInfo ( mkClosureLFInfo )
34 import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC,
37 import CostCentre ( CostCentre, CostCentreStack )
38 import FiniteMap ( FiniteMap )
39 import Id ( Id, idName )
40 import Module ( Module, moduleString, moduleName,
41 ModuleName, moduleNameString )
42 import PrimRep ( getPrimRepSize, PrimRep(..) )
44 import TyCon ( TyCon, isDataTyCon )
45 import Class ( Class, classTyCon )
46 import BasicTypes ( TopLevelFlag(..) )
47 import UniqSupply ( mkSplitUniqSupply )
48 import ErrUtils ( dumpIfSet )
50 import Panic ( assertPanic )
56 codeGen :: Module -- Module name
57 -> [ModuleName] -- Import names
58 -> ([CostCentre], -- Local cost-centres needing declaring/registering
59 [CostCentre], -- "extern" cost-centres needing declaring
60 [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
61 -> [Id] -- foreign-exported binders
62 -> [TyCon] -> [Class] -- Local tycons and classes
63 -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
64 -> IO AbstractC -- Output
66 codeGen mod_name imported_modules cost_centre_info fe_binders
67 tycons classes stg_binds
68 = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
70 datatype_stuff = genStaticConBits cinfo data_tycons
71 code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
72 init_stuff = mkModuleInit fe_binders mod_name imported_modules
75 abstractC = mkAbstractCs [ init_stuff,
79 flat_abstractC = flattenAbsC fl_uniqs abstractC
81 dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >>
85 data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
86 -- Generate info tables for the data constrs arising
87 -- from class decls as well
89 maybe_split = if opt_EnsureSplittableC
92 cinfo = MkCompInfo mod_name
95 %************************************************************************
97 \subsection[codegen-init]{Module initialisation code}
99 %************************************************************************
103 :: [Id] -- foreign exported functions
104 -> Module -- module name
105 -> [ModuleName] -- import names
106 -> ([CostCentre], -- cost centre info
110 mkModuleInit fe_binders mod imps cost_centre_info
113 map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
116 map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
118 (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
121 = CLitLit (_PK_ ("__init_" ++ moduleNameString mod_name)) AddrRep
123 mk_import_register import_name
124 = CMacroStmt REGISTER_IMPORT [mk_reg_lbl import_name]
126 register_imports = map mk_import_register imps
130 CModuleInitBlock (mk_reg_lbl (Module.moduleName mod))
131 (mkAbstractCs (register_fes ++
137 Cost-centre profiling: Besides the usual stuff, we must produce
138 declarations for the cost-centres defined in this module;
140 (The local cost-centres involved in this are passed into the
144 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
145 | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
148 map (CCostCentreDecl True) local_CCs ++
149 map (CCostCentreDecl False) extern_CCs ++
150 map CCostCentreStackDecl singleton_CCSs),
151 mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
154 mkCcRegister ccs cc_stacks
156 register_ccs = mkAbstractCs (map mk_register ccs)
157 register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
159 [ register_ccs, register_cc_stacks ]
162 = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
165 = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
168 %************************************************************************
170 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
172 %************************************************************************
174 @cgTopBindings@ is only used for top-level bindings, since they need
175 to be allocated statically (not in the heap) and need to be labelled.
176 No unboxed bindings can happen at top level.
178 In the code below, the static bindings are accumulated in the
179 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
180 This is so that we can write the top level processing in a compositional
181 style, with the increasing static environment being plumbed as a state
185 cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
187 cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
189 cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
191 cgTopBinding split ((StgNonRec name rhs), srt)
193 absC (mkSRT srt_label srt) `thenC`
194 setSRTLabel srt_label (
195 cgTopRhs name rhs `thenFC` \ (name, info) ->
199 srt_label = mkSRTLabel (idName name)
201 cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
203 absC (mkSRT srt_label srt) `thenC`
204 setSRTLabel srt_label (
205 fixC (\ new_binds -> addBindsC new_binds `thenC`
206 mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
207 ) `thenFC` \ new_binds ->
211 srt_label = mkSRTLabel (idName name)
213 mkSRT :: CLabel -> [Id] -> AbstractC
214 mkSRT lbl [] = AbsCNop
215 mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
217 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
218 -- to enclose the listFCs in cgTopBinding, but that tickled the
219 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
221 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
222 -- the Id is passed along for setting up a binding...
224 cgTopRhs bndr (StgRhsCon cc con args)
225 = forkStatics (cgTopRhsCon bndr con args (all zero_size args))
227 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
229 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
230 = ASSERT(null fvs) -- There should be no free variables
231 getSRTLabel `thenFC` \srt_label ->
233 mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
235 forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)