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,
35 opt_D_dump_absC, opt_SccGroup
37 import CostCentre ( CostCentre, CostCentreStack )
38 import FiniteMap ( FiniteMap )
39 import Id ( Id, idName )
40 import Module ( Module, moduleString, ModuleName, moduleNameString )
41 import PrimRep ( getPrimRepSize, PrimRep(..) )
43 import TyCon ( TyCon, isDataTyCon )
44 import Class ( Class, classTyCon )
45 import BasicTypes ( TopLevelFlag(..) )
46 import UniqSupply ( mkSplitUniqSupply )
47 import ErrUtils ( dumpIfSet )
49 import Panic ( assertPanic )
55 codeGen :: Module -- Module name
56 -> [ModuleName] -- Import names
57 -> ([CostCentre], -- Local cost-centres needing declaring/registering
58 [CostCentre], -- "extern" cost-centres needing declaring
59 [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
60 -> [TyCon] -> [Class] -- Local tycons and classes
61 -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
62 -> IO AbstractC -- Output
64 codeGen mod_name imported_modules cost_centre_info
65 tycons classes stg_binds
66 = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
68 datatype_stuff = genStaticConBits cinfo data_tycons
69 code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
70 cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info
72 abstractC = mkAbstractCs [ cost_centre_stuff,
76 flat_abstractC = flattenAbsC fl_uniqs abstractC
78 dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >>
82 data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
83 -- Generate info tables for the data constrs arising
84 -- from class decls as well
86 maybe_split = if opt_EnsureSplittableC
89 cinfo = MkCompInfo mod_name
92 Cost-centre profiling:
93 Besides the usual stuff, we must produce:
95 * Declarations for the cost-centres defined in this module;
96 * Code to participate in "registering" all the cost-centres
97 in the program (done at startup time when the pgm is run).
99 (The local cost-centres involved in this are passed
100 into the code-generator, as are the imported-modules' names.)
103 mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs)
104 | not opt_SccProfilingOn = AbsCNop
105 | otherwise = mkAbstractCs (
106 map (CCostCentreDecl True) local_CCs ++
107 map (CCostCentreDecl False) extern_CCs ++
108 map CCostCentreStackDecl singleton_CCSs ++
109 mkCcRegister local_CCs singleton_CCSs import_names
113 mkCcRegister ccs cc_stacks import_names
115 register_ccs = mkAbstractCs (map mk_register ccs)
117 = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
118 register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
121 CCallProfCCMacro SLIT("START_REGISTER_CCS")
122 [ CLitLit (_PK_ ("_reg" ++ moduleString mod_name)) AddrRep],
126 CCallProfCCMacro SLIT("END_REGISTER_CCS") []
130 = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
133 = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
135 mk_import_register import_name
136 = CCallProfCCMacro SLIT("REGISTER_IMPORT")
137 [CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep]
140 %************************************************************************
142 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
144 %************************************************************************
146 @cgTopBindings@ is only used for top-level bindings, since they need
147 to be allocated statically (not in the heap) and need to be labelled.
148 No unboxed bindings can happen at top level.
150 In the code below, the static bindings are accumulated in the
151 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
152 This is so that we can write the top level processing in a compositional
153 style, with the increasing static environment being plumbed as a state
157 cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
159 cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
161 cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
163 cgTopBinding split ((StgNonRec name rhs), srt)
165 absC (mkSRT srt_label srt) `thenC`
166 setSRTLabel srt_label (
167 cgTopRhs name rhs `thenFC` \ (name, info) ->
171 srt_label = mkSRTLabel (idName name)
173 cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
175 absC (mkSRT srt_label srt) `thenC`
176 setSRTLabel srt_label (
177 fixC (\ new_binds -> addBindsC new_binds `thenC`
178 mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
179 ) `thenFC` \ new_binds ->
183 srt_label = mkSRTLabel (idName name)
185 mkSRT :: CLabel -> [Id] -> AbstractC
186 mkSRT lbl [] = AbsCNop
187 mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
189 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
190 -- to enclose the listFCs in cgTopBinding, but that tickled the
191 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
193 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
194 -- the Id is passed along for setting up a binding...
196 cgTopRhs bndr (StgRhsCon cc con args)
197 = forkStatics (cgTopRhsCon bndr con args (all zero_size args))
199 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
201 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
202 = ASSERT(null fvs) -- There should be no free variables
203 getSRTLabel `thenFC` \srt_label ->
205 mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
207 forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)