Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / codeGen / CodeGen.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The Code Generator
7
8 This module says how things get going at the top level.
9
10 @codeGen@ is the interface to the outside world. The \tr{cgTop*}
11 functions drive the mangling of top-level bindings.
12
13 \begin{code}
14
15 module CodeGen ( codeGen ) where
16
17 #include "HsVersions.h"
18
19 -- Required so that CgExpr is reached via at least one non-SOURCE
20 -- import. Before, that wasn't the case, and CM therefore didn't
21 -- bother to compile it.
22 import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
23 import CgProf
24 import CgMonad
25 import CgBindery
26 import CgClosure
27 import CgCon
28 import CgUtils
29 import CgHpc
30
31 import CLabel
32 import OldCmm
33 import OldPprCmm
34
35 import StgSyn
36 import PrelNames
37 import DynFlags
38 import StaticFlags
39
40 import HscTypes
41 import CostCentre
42 import Id
43 import Name
44 import TyCon
45 import Module
46 import ErrUtils
47 import Panic
48
49 codeGen :: DynFlags
50         -> Module                     -- Module we are compiling
51         -> [TyCon]                    -- Type constructors
52         -> CollectedCCs               -- (Local/global) cost-centres needing declaring/registering.
53         -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
54         -> HpcInfo                    -- Profiling info
55         -> IO [CmmGroup]
56               -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
57               -- possible for object splitting to split up the
58               -- pieces later.
59
60 codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do
61     showPass dflags "CodeGen"
62     code_stuff <-
63         initC dflags this_mod $ do
64             cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
65             cmm_tycons <- mapM cgTyCon data_tycons
66             cmm_init   <- getCmm (mkModuleInit dflags cost_centre_info this_mod hpc_info)
67             return (cmm_init : cmm_binds ++ cmm_tycons)
68                 -- Put datatype_stuff after code_stuff, because the
69                 -- datatype closure table (for enumeration types) to
70                 -- (say) PrelBase_True_closure, which is defined in
71                 -- code_stuff
72
73                 -- Note [codegen-split-init] the cmm_init block must
74                 -- come FIRST.  This is because when -split-objs is on
75                 -- we need to combine this block with its
76                 -- initialisation routines; see Note
77                 -- [pipeline-split-init].
78
79     dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff)
80     return code_stuff
81
82 mkModuleInit
83         :: DynFlags
84         -> CollectedCCs         -- cost centre info
85         -> Module
86         -> HpcInfo
87         -> Code
88
89 mkModuleInit dflags cost_centre_info this_mod hpc_info
90   = do  { -- Allocate the static boolean that records if this
91         ; whenC (opt_Hpc) $
92               hpcTable this_mod hpc_info
93
94         ; whenC (opt_SccProfilingOn) $ do
95             initCostCentres cost_centre_info
96
97             -- For backwards compatibility: user code may refer to this
98             -- label for calling hs_add_root().
99         ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) []))
100
101         ; whenC (this_mod == mainModIs dflags) $
102              emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
103     }
104 \end{code}
105
106
107
108 Cost-centre profiling: Besides the usual stuff, we must produce
109 declarations for the cost-centres defined in this module;
110
111 (The local cost-centres involved in this are passed into the
112 code-generator.)
113
114 \begin{code}
115 initCostCentres :: CollectedCCs -> Code
116 -- Emit the declarations, and return code to register them
117 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
118   | not opt_SccProfilingOn = nopC
119   | otherwise
120   = do  { mapM_ emitCostCentreDecl       local_CCs
121         ; mapM_ emitCostCentreStackDecl  singleton_CCSs
122         }
123 \end{code}
124
125 %************************************************************************
126 %*                                                                      *
127 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
128 %*                                                                      *
129 %************************************************************************
130
131 @cgTopBinding@ is only used for top-level bindings, since they need
132 to be allocated statically (not in the heap) and need to be labelled.
133 No unboxed bindings can happen at top level.
134
135 In the code below, the static bindings are accumulated in the
136 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
137 This is so that we can write the top level processing in a compositional
138 style, with the increasing static environment being plumbed as a state
139 variable.
140
141 \begin{code}
142 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
143 cgTopBinding dflags (StgNonRec id rhs, srts)
144   = do  { id' <- maybeExternaliseId dflags id
145         ; mapM_ (mkSRT [id']) srts
146         ; (id,info) <- cgTopRhs id' rhs
147         ; addBindC id info      -- Add the *un-externalised* Id to the envt,
148                                 -- so we find it when we look up occurrences
149         }
150
151 cgTopBinding dflags (StgRec pairs, srts)
152   = do  { let (bndrs, rhss) = unzip pairs
153         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
154         ; let pairs' = zip bndrs' rhss
155         ; mapM_ (mkSRT bndrs')  srts
156         ; _new_binds <- fixC (\ new_binds -> do
157                 { addBindsC new_binds
158                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
159         ; nopC }
160
161 mkSRT :: [Id] -> (Id,[Id]) -> Code
162 mkSRT _ (_,[])  = nopC
163 mkSRT these (id,ids)
164   = do  { ids <- mapFCs remap ids
165         ; id  <- remap id
166         ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id))
167                (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
168         }
169   where
170         -- Sigh, better map all the ids against the environment in
171         -- case they've been externalised (see maybeExternaliseId below).
172     remap id = case filter (==id) these of
173                 (id':_) -> returnFC id'
174                 [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
175
176 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
177 -- to enclose the listFCs in cgTopBinding, but that tickled the
178 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
179
180 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
181         -- The Id is passed along for setting up a binding...
182         -- It's already been externalised if necessary
183
184 cgTopRhs bndr (StgRhsCon _cc con args)
185   = forkStatics (cgTopRhsCon bndr con args)
186
187 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
188   = ASSERT(null fvs)    -- There should be no free variables
189     setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
190     setSRT srt $
191     forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
192 \end{code}
193
194
195 %************************************************************************
196 %*                                                                      *
197 \subsection{Stuff to support splitting}
198 %*                                                                      *
199 %************************************************************************
200
201 If we're splitting the object, we need to externalise all the top-level names
202 (and then make sure we only use the externalised one in any C label we use
203 which refers to this name).
204
205 \begin{code}
206 maybeExternaliseId :: DynFlags -> Id -> FCode Id
207 maybeExternaliseId dflags id
208   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
209     isInternalName name = do { mod <- getModuleName
210                              ; returnFC (setIdName id (externalise mod)) }
211   | otherwise           = returnFC id
212   where
213     externalise mod = mkExternalName uniq mod new_occ loc
214     name    = idName id
215     uniq    = nameUnique name
216     new_occ = mkLocalOcc uniq (nameOccName name)
217     loc     = nameSrcSpan name
218         -- We want to conjure up a name that can't clash with any
219         -- existing name.  So we generate
220         --      Mod_$L243foo
221         -- where 243 is the unique.
222 \end{code}