[project @ 2005-04-28 16:05:54 by simonpj]
[ghc-hetmet.git] / ghc / compiler / codeGen / CodeGen.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[CodeGen]{@CodeGen@: main module of the code generator}
5
6 This module says how things get going at the top level.
7
8 @codeGen@ is the interface to the outside world.  The \tr{cgTop*}
9 functions drive the mangling of top-level bindings.
10
11 %************************************************************************
12 %*                                                                      *
13 \subsection[codeGen-outside-interface]{The code generator's offering to the world}
14 %*                                                                      *
15 %************************************************************************
16
17 \begin{code}
18 module CodeGen ( codeGen ) where
19
20 #include "HsVersions.h"
21
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
26 import CgProf
27 import CgMonad
28 import CgBindery        ( CgIdInfo, addBindC, addBindsC, getCgIdInfo,
29                           cgIdInfoId )
30 import CgClosure        ( cgTopRhsClosure )
31 import CgCon            ( cgTopRhsCon, cgTyCon )
32 import CgUtils          ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
33
34 import CLabel
35 import Cmm
36 import CmmUtils         ( zeroCLit, mkIntCLit, mkLblExpr )
37 import PprCmm           ( pprCmms )
38 import MachOp           ( wordRep, MachHint(..) )
39
40 import StgSyn
41 import PrelNames        ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
42 import DynFlags         ( DynFlags(..), DynFlag(..), dopt )
43 import StaticFlags      ( opt_SccProfilingOn )
44
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            ( TyCon )
51 import Module           ( Module, mkModule )
52 import ErrUtils         ( dumpIfSet_dyn, showPass )
53 import Panic            ( assertPanic )
54
55 #ifdef DEBUG
56 import Outputable
57 #endif
58 \end{code}
59
60 \begin{code}
61 codeGen :: DynFlags
62         -> Module
63         -> [TyCon]
64         -> ForeignStubs
65         -> [Module]             -- directly-imported modules
66         -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
67         -> [(StgBinding,[(Id,[Id])])]   -- Bindings to convert, with SRTs
68         -> IO [Cmm]             -- Output
69
70 codeGen dflags this_mod data_tycons foreign_stubs imported_mods 
71         cost_centre_info stg_binds
72   = do  
73   { showPass dflags "CodeGen"
74   ; let way = buildTag dflags
75         mb_main_mod = mainModIs dflags
76
77 -- Why?
78 --   ; mapM_ (\x -> seq x (return ())) data_tycons
79
80   ; code_stuff <- initC dflags this_mod $ do 
81                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
82                 ; cmm_tycons <- mapM cgTyCon data_tycons
83                 ; cmm_init   <- getCmm (mkModuleInit dflags way cost_centre_info 
84                                              this_mod mb_main_mod
85                                              foreign_stubs imported_mods)
86                 ; return (cmm_binds ++ concat cmm_tycons
87                         ++ if opt_SccProfilingOn 
88 #if defined(mingw32_HOST_OS)
89                               || True
90 #endif
91                             then [cmm_init] 
92                             else [])
93                 }
94                 -- Put datatype_stuff after code_stuff, because the
95                 -- datatype closure table (for enumeration types) to
96                 -- (say) PrelBase_True_closure, which is defined in
97                 -- code_stuff
98
99   ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
100
101   ; return code_stuff }
102 \end{code}
103
104 %************************************************************************
105 %*                                                                      *
106 \subsection[codegen-init]{Module initialisation code}
107 %*                                                                      *
108 %************************************************************************
109
110 /* -----------------------------------------------------------------------------
111    Module initialisation
112
113    The module initialisation code looks like this, roughly:
114
115         FN(__stginit_Foo) {
116           JMP_(__stginit_Foo_1_p)
117         }
118
119         FN(__stginit_Foo_1_p) {
120         ...
121         }
122
123    We have one version of the init code with a module version and the
124    'way' attached to it.  The version number helps to catch cases
125    where modules are not compiled in dependency order before being
126    linked: if a module has been compiled since any modules which depend on
127    it, then the latter modules will refer to a different version in their
128    init blocks and a link error will ensue.
129
130    The 'way' suffix helps to catch cases where modules compiled in different
131    ways are linked together (eg. profiled and non-profiled).
132
133    We provide a plain, unadorned, version of the module init code
134    which just jumps to the version with the label and way attached.  The
135    reason for this is that when using foreign exports, the caller of
136    startupHaskell() must supply the name of the init function for the "top"
137    module in the program, and we don't want to require that this name
138    has the version and way info appended to it.
139    --------------------------------------------------------------------------  */
140
141 We initialise the module tree by keeping a work-stack, 
142         * pointed to by Sp
143         * that grows downward
144         * Sp points to the last occupied slot
145
146
147 \begin{code}
148 mkModuleInit 
149         :: DynFlags
150         -> String               -- the "way"
151         -> CollectedCCs         -- cost centre info
152         -> Module
153         -> Maybe String         -- Just m ==> we have flag: -main-is Foo.baz 
154         -> ForeignStubs
155         -> [Module]
156         -> Code
157 mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
158   = do  {       
159
160         -- Allocate the static boolean that records if this
161         -- module has been registered already
162         ; emitData Data [CmmDataLabel moduleRegdLabel, 
163                          CmmStaticLit zeroCLit]
164
165         ; emitSimpleProc real_init_lbl $ do
166             {   -- The return-code pops the work stack by 
167                 -- incrementing Sp, and then jumpd to the popped item
168               ret_blk <- forkLabelledCode $ stmtsC
169                         [ CmmAssign spReg (cmmRegOffW spReg 1)
170                         , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
171
172             ; init_blk <- forkLabelledCode $ do
173                             { mod_init_code; stmtC (CmmBranch ret_blk) }
174                         
175             ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
176                         ret_blk)
177             ; stmtC (CmmBranch init_blk)            
178             }
179
180
181             -- Make the "plain" procedure jump to the "real" init procedure
182         ; emitSimpleProc plain_init_lbl jump_to_init
183
184         -- When compiling the module in which the 'main' function lives,
185         -- (that is, this_mod == main_mod)
186         -- we inject an extra stg_init procedure for stg_init_ZCMain, for the 
187         -- RTS to invoke.  We must consult the -main-is flag in case the
188         -- user specified a different function to Main.main
189         ; whenC (this_mod == main_mod)
190                 (emitSimpleProc plain_main_init_lbl jump_to_init)
191     }
192   where
193     plain_init_lbl = mkPlainModuleInitLabel dflags this_mod
194     real_init_lbl  = mkModuleInitLabel dflags this_mod way
195     plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN
196
197     jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
198
199     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
200
201     main_mod = case mb_main_mod of
202                         Just mod_name -> mkModule mod_name
203                         Nothing       -> mAIN
204
205     -- Main refers to GHC.TopHandler.runIO, so make sure we call the
206     -- init function for GHC.TopHandler.
207     extra_imported_mods
208         | this_mod == main_mod = [pREL_TOP_HANDLER]
209         | otherwise            = []
210
211     mod_init_code = do
212         {       -- Set mod_reg to 1 to record that we've been here
213           stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
214
215                 -- Now do local stuff
216 #if defined(mingw32_HOST_OS)
217         ; registerForeignExports foreign_stubs
218 #endif
219         ; initCostCentres cost_centre_info
220         ; mapCs (registerModuleImport dflags way) 
221                 (imported_mods++extra_imported_mods)
222         } 
223
224
225 -----------------------
226 registerModuleImport :: DynFlags -> String -> Module -> Code
227 registerModuleImport dflags way mod 
228   | mod == gHC_PRIM
229   = nopC 
230   | otherwise   -- Push the init procedure onto the work stack
231   = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
232            , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ]
233
234 -----------------------
235 registerForeignExports :: ForeignStubs -> Code
236 registerForeignExports NoStubs 
237   = nopC
238 registerForeignExports (ForeignStubs _ _ _ fe_bndrs)
239   = mapM_ mk_export_register fe_bndrs
240   where
241         mk_export_register bndr
242           = emitRtsCall SLIT("getStablePtr") 
243                 [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))), 
244                    PtrHint) ]
245 \end{code}
246
247
248
249 Cost-centre profiling: Besides the usual stuff, we must produce
250 declarations for the cost-centres defined in this module;
251
252 (The local cost-centres involved in this are passed into the
253 code-generator.)
254
255 \begin{code}
256 initCostCentres :: CollectedCCs -> Code
257 -- Emit the declarations, and return code to register them
258 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
259   | not opt_SccProfilingOn = nopC
260   | otherwise
261   = do  { mapM_ emitCostCentreDecl       local_CCs
262         ; mapM_ emitCostCentreStackDecl  singleton_CCSs
263         ; mapM_ emitRegisterCC           local_CCs
264         ; mapM_ emitRegisterCCS          singleton_CCSs
265         }
266 \end{code}
267
268 %************************************************************************
269 %*                                                                      *
270 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
271 %*                                                                      *
272 %************************************************************************
273
274 @cgTopBinding@ is only used for top-level bindings, since they need
275 to be allocated statically (not in the heap) and need to be labelled.
276 No unboxed bindings can happen at top level.
277
278 In the code below, the static bindings are accumulated in the
279 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
280 This is so that we can write the top level processing in a compositional
281 style, with the increasing static environment being plumbed as a state
282 variable.
283
284 \begin{code}
285 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
286 cgTopBinding dflags (StgNonRec id rhs, srts)
287   = do  { id' <- maybeExternaliseId dflags id
288         ; mapM_ (mkSRT dflags [id']) srts
289         ; (id,info) <- cgTopRhs id' rhs
290         ; addBindC id info      -- Add the *un-externalised* Id to the envt,
291                                 -- so we find it when we look up occurrences
292         }
293
294 cgTopBinding dflags (StgRec pairs, srts)
295   = do  { let (bndrs, rhss) = unzip pairs
296         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
297         ; let pairs' = zip bndrs' rhss
298         ; mapM_ (mkSRT dflags bndrs')  srts
299         ; _new_binds <- fixC (\ new_binds -> do 
300                 { addBindsC new_binds
301                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
302         ; nopC }
303
304 mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code
305 mkSRT dflags these (id,[])  = nopC
306 mkSRT dflags these (id,ids)
307   = do  { ids <- mapFCs remap ids
308         ; id  <- remap id
309         ; emitRODataLits (mkSRTLabel (idName id)) 
310                        (map (CmmLabel . mkClosureLabel dflags . idName) ids)
311         }
312   where
313         -- Sigh, better map all the ids against the environment in 
314         -- case they've been externalised (see maybeExternaliseId below).
315     remap id = case filter (==id) these of
316                 (id':_) -> returnFC id'
317                 [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
318
319 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
320 -- to enclose the listFCs in cgTopBinding, but that tickled the
321 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
322
323 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
324         -- The Id is passed along for setting up a binding...
325         -- It's already been externalised if necessary
326
327 cgTopRhs bndr (StgRhsCon cc con args)
328   = forkStatics (cgTopRhsCon bndr con args)
329
330 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
331   = ASSERT(null fvs)    -- There should be no free variables
332     setSRTLabel (mkSRTLabel (idName bndr)) $ 
333     forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
334 \end{code}
335
336
337 %************************************************************************
338 %*                                                                      *
339 \subsection{Stuff to support splitting}
340 %*                                                                      *
341 %************************************************************************
342
343 If we're splitting the object, we need to externalise all the top-level names
344 (and then make sure we only use the externalised one in any C label we use
345 which refers to this name).
346
347 \begin{code}
348 maybeExternaliseId :: DynFlags -> Id -> FCode Id
349 maybeExternaliseId dflags id
350   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
351     isInternalName name = do { mod <- moduleName
352                              ; returnFC (setIdName id (externalise mod)) }
353   | otherwise           = returnFC id
354   where
355     externalise mod = mkExternalName uniq mod new_occ Nothing loc
356     name    = idName id
357     uniq    = nameUnique name
358     new_occ = mkLocalOcc uniq (nameOccName name)
359     loc     = nameSrcLoc name
360         -- We want to conjure up a name that can't clash with any
361         -- existing name.  So we generate
362         --      Mod_$L243foo
363         -- where 243 is the unique.
364 \end{code}