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
30 import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
32 import PprAbsC ( dumpRealC )
33 import AbsCUtils ( mkAbstractCs, flattenAbsC )
34 import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
35 import CgClosure ( cgTopRhsClosure )
36 import CgCon ( cgTopRhsCon )
37 import CgConTbls ( genStaticConBits )
38 import ClosureInfo ( mkClosureLFInfo )
39 import CmdLineOpts ( DynFlags, DynFlag(..),
40 opt_SccProfilingOn, opt_EnsureSplittableC )
41 import CostCentre ( CostCentre, CostCentreStack )
42 import Id ( Id, idName, setIdName )
43 import Name ( globaliseName )
44 import Module ( Module )
45 import PrimRep ( PrimRep(..) )
46 import TyCon ( TyCon, isDataTyCon )
47 import BasicTypes ( TopLevelFlag(..) )
48 import UniqSupply ( mkSplitUniqSupply )
49 import ErrUtils ( dumpIfSet_dyn, showPass )
50 import Panic ( assertPanic )
59 -> Module -- Module name
60 -> [Module] -- Import names
61 -> ([CostCentre], -- Local cost-centres needing declaring/registering
62 [CostCentre], -- "extern" cost-centres needing declaring
63 [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
64 -> [Id] -- foreign-exported binders
65 -> [TyCon] -- Local tycons, including ones from classes
66 -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
67 -> IO AbstractC -- Output
69 codeGen dflags mod_name imported_modules cost_centre_info fe_binders
71 = do { showPass dflags "CodeGen"
73 ; fl_uniqs <- mkSplitUniqSupply 'f'
75 datatype_stuff = genStaticConBits cinfo data_tycons
76 code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
77 init_stuff = mkModuleInit fe_binders mod_name imported_modules
80 abstractC = mkAbstractCs [ maybeSplitCode,
84 -- Put datatype_stuff after code_stuff, because the
85 -- datatype closure table (for enumeration types)
86 -- to (say) PrelBase_True_closure, which is defined in code_stuff
88 flat_abstractC = flattenAbsC fl_uniqs abstractC
90 ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
91 ; return flat_abstractC
94 data_tycons = filter isDataTyCon tycons
95 cinfo = MkCompInfo mod_name
98 %************************************************************************
100 \subsection[codegen-init]{Module initialisation code}
102 %************************************************************************
106 :: [Id] -- foreign exported functions
107 -> Module -- module name
108 -> [Module] -- import names
109 -> ([CostCentre], -- cost centre info
113 mkModuleInit fe_binders mod imps cost_centre_info
116 map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
119 map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
121 (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
123 mk_import_register imp =
124 CMacroStmt REGISTER_IMPORT [
125 CLbl (mkModuleInitLabel imp) AddrRep
128 register_imports = map mk_import_register imps
132 CModuleInitBlock (mkModuleInitLabel mod)
133 (mkAbstractCs (register_fes ++
139 Cost-centre profiling: Besides the usual stuff, we must produce
140 declarations for the cost-centres defined in this module;
142 (The local cost-centres involved in this are passed into the
146 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
147 | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
150 map (CCostCentreDecl True) local_CCs ++
151 map (CCostCentreDecl False) extern_CCs ++
152 map CCostCentreStackDecl singleton_CCSs),
153 mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
156 mkCcRegister ccs cc_stacks
158 register_ccs = mkAbstractCs (map mk_register ccs)
159 register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
161 [ register_ccs, register_cc_stacks ]
164 = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
167 = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
170 %************************************************************************
172 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
174 %************************************************************************
176 @cgTopBinding@ is only used for top-level bindings, since they need
177 to be allocated statically (not in the heap) and need to be labelled.
178 No unboxed bindings can happen at top level.
180 In the code below, the static bindings are accumulated in the
181 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
182 This is so that we can write the top level processing in a compositional
183 style, with the increasing static environment being plumbed as a state
187 cgTopBinding :: (StgBinding,[Id]) -> Code
188 cgTopBinding (StgNonRec srt_info id rhs, srt)
189 = absC maybeSplitCode `thenC`
190 maybeGlobaliseId id `thenFC` \ id' ->
192 srt_label = mkSRTLabel (idName id')
194 mkSRT srt_label srt [] `thenC`
195 setSRTLabel srt_label (
196 cgTopRhs id' rhs srt_info `thenFC` \ (id, info) ->
200 cgTopBinding (StgRec srt_info pairs, srt)
201 = absC maybeSplitCode `thenC`
203 (bndrs, rhss) = unzip pairs
205 mapFCs maybeGlobaliseId bndrs `thenFC` \ bndrs'@(id:_) ->
207 srt_label = mkSRTLabel (idName id)
208 pairs' = zip bndrs' rhss
210 mkSRT srt_label srt bndrs' `thenC`
211 setSRTLabel srt_label (
213 addBindsC new_binds `thenC`
214 mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
215 ) `thenFC` \ new_binds -> nopC
218 mkSRT :: CLabel -> [Id] -> [Id] -> Code
219 mkSRT lbl [] these = nopC
221 = mapFCs remap ids `thenFC` \ ids ->
222 absC (CSRT lbl (map (mkClosureLabel . idName) ids))
224 -- sigh, better map all the ids against the environment in case they've
225 -- been globalised (see maybeGlobaliseId below).
226 remap id = case filter (==id) these of
227 [] -> getCAddrModeAndInfo id
228 `thenFC` \ (id, _, _) -> returnFC id
229 (id':_) -> returnFC id'
231 -- If we're splitting the object, we need to globalise all the top-level names
232 -- (and then make sure we only use the globalised one in any C label we use
233 -- which refers to this name).
234 maybeGlobaliseId :: Id -> FCode Id
236 | opt_EnsureSplittableC
237 = moduleName `thenFC` \ mod ->
238 returnFC (setIdName id (globaliseName (idName id) mod))
239 | otherwise -- Globalise the name for -split-objs
243 | opt_EnsureSplittableC = CSplitMarker
244 | otherwise = AbsCNop
246 -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
247 -- to enclose the listFCs in cgTopBinding, but that tickled the
248 -- statics "error" call in initC. I DON'T UNDERSTAND WHY!
250 cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
251 -- the Id is passed along for setting up a binding...
253 cgTopRhs bndr (StgRhsCon cc con args) srt
254 = maybeGlobaliseId bndr `thenFC` \ bndr' ->
255 forkStatics (cgTopRhsCon bndr con args)
257 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
258 = -- There should be no free variables
261 lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
263 maybeGlobaliseId bndr `thenFC` \ bndr' ->
264 forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info)