bb82da265ea848585a3005ce33f73262549fedff
[ghc.git] / compiler / codeGen / StgCmm.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Stg to C-- code generation
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module StgCmm ( codeGen ) where
12
13 #include "HsVersions.h"
14
15 import StgCmmProf (initCostCentres, ldvEnter)
16 import StgCmmMonad
17 import StgCmmEnv
18 import StgCmmBind
19 import StgCmmCon
20 import StgCmmLayout
21 import StgCmmUtils
22 import StgCmmClosure
23 import StgCmmHpc
24 import StgCmmTicky
25
26 import Cmm
27 import CLabel
28
29 import StgSyn
30 import DynFlags
31
32 import HscTypes
33 import CostCentre
34 import Id
35 import IdInfo
36 import RepType
37 import DataCon
38 import Name
39 import TyCon
40 import Module
41 import Outputable
42 import Stream
43 import BasicTypes
44
45 import OrdList
46 import MkGraph
47
48 import Data.IORef
49 import Control.Monad (when,void)
50 import Util
51
52 codeGen :: DynFlags
53 -> Module
54 -> [TyCon]
55 -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
56 -> [StgBinding] -- Bindings to convert
57 -> HpcInfo
58 -> Stream IO CmmGroup () -- Output as a stream, so codegen can
59 -- be interleaved with output
60
61 codeGen dflags this_mod data_tycons
62 cost_centre_info stg_binds hpc_info
63 = do { -- cg: run the code generator, and yield the resulting CmmGroup
64 -- Using an IORef to store the state is a bit crude, but otherwise
65 -- we would need to add a state monad layer.
66 ; cgref <- liftIO $ newIORef =<< initC
67 ; let cg :: FCode () -> Stream IO CmmGroup ()
68 cg fcode = do
69 cmm <- liftIO $ do
70 st <- readIORef cgref
71 let (a,st') = runC dflags this_mod st (getCmm fcode)
72
73 -- NB. stub-out cgs_tops and cgs_stmts. This fixes
74 -- a big space leak. DO NOT REMOVE!
75 writeIORef cgref $! st'{ cgs_tops = nilOL,
76 cgs_stmts = mkNop }
77 return a
78 yield cmm
79
80 -- Note [codegen-split-init] the cmm_init block must come
81 -- FIRST. This is because when -split-objs is on we need to
82 -- combine this block with its initialisation routines; see
83 -- Note [pipeline-split-init].
84 ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
85
86 ; mapM_ (cg . cgTopBinding dflags) stg_binds
87
88 -- Put datatype_stuff after code_stuff, because the
89 -- datatype closure table (for enumeration types) to
90 -- (say) PrelBase_True_closure, which is defined in
91 -- code_stuff
92 ; let do_tycon tycon = do
93 -- Generate a table of static closures for an
94 -- enumeration type Note that the closure pointers are
95 -- tagged.
96 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
97 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
98
99 ; mapM_ do_tycon data_tycons
100 }
101
102 ---------------------------------------------------------------
103 -- Top-level bindings
104 ---------------------------------------------------------------
105
106 {- 'cgTopBinding' is only used for top-level bindings, since they need
107 to be allocated statically (not in the heap) and need to be labelled.
108 No unboxed bindings can happen at top level.
109
110 In the code below, the static bindings are accumulated in the
111 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
112 This is so that we can write the top level processing in a compositional
113 style, with the increasing static environment being plumbed as a state
114 variable. -}
115
116 cgTopBinding :: DynFlags -> StgBinding -> FCode ()
117 cgTopBinding dflags (StgNonRec id rhs)
118 = do { id' <- maybeExternaliseId dflags id
119 ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
120 ; fcode
121 ; addBindC info -- Add the *un-externalised* Id to the envt,
122 -- so we find it when we look up occurrences
123 }
124
125 cgTopBinding dflags (StgRec pairs)
126 = do { let (bndrs, rhss) = unzip pairs
127 ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
128 ; let pairs' = zip bndrs' rhss
129 r = unzipWith (cgTopRhs dflags Recursive) pairs'
130 (infos, fcodes) = unzip r
131 ; addBindsC infos
132 ; sequence_ fcodes
133 }
134
135
136 cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
137 -- The Id is passed along for setting up a binding...
138 -- It's already been externalised if necessary
139
140 cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
141 = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
142 -- con args are always non-void,
143 -- see Note [Post-unarisation invariants] in UnariseStg
144
145 cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
146 = ASSERT(null fvs) -- There should be no free variables
147 cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
148
149
150 ---------------------------------------------------------------
151 -- Module initialisation code
152 ---------------------------------------------------------------
153
154 {- The module initialisation code looks like this, roughly:
155
156 FN(__stginit_Foo) {
157 JMP_(__stginit_Foo_1_p)
158 }
159
160 FN(__stginit_Foo_1_p) {
161 ...
162 }
163
164 We have one version of the init code with a module version and the
165 'way' attached to it. The version number helps to catch cases
166 where modules are not compiled in dependency order before being
167 linked: if a module has been compiled since any modules which depend on
168 it, then the latter modules will refer to a different version in their
169 init blocks and a link error will ensue.
170
171 The 'way' suffix helps to catch cases where modules compiled in different
172 ways are linked together (eg. profiled and non-profiled).
173
174 We provide a plain, unadorned, version of the module init code
175 which just jumps to the version with the label and way attached. The
176 reason for this is that when using foreign exports, the caller of
177 startupHaskell() must supply the name of the init function for the "top"
178 module in the program, and we don't want to require that this name
179 has the version and way info appended to it.
180
181 We initialise the module tree by keeping a work-stack,
182 * pointed to by Sp
183 * that grows downward
184 * Sp points to the last occupied slot
185 -}
186
187 mkModuleInit
188 :: CollectedCCs -- cost centre info
189 -> Module
190 -> HpcInfo
191 -> FCode ()
192
193 mkModuleInit cost_centre_info this_mod hpc_info
194 = do { initHpc this_mod hpc_info
195 ; initCostCentres cost_centre_info
196 -- For backwards compatibility: user code may refer to this
197 -- label for calling hs_add_root().
198 ; let lbl = mkPlainModuleInitLabel this_mod
199 ; emitDecl (CmmData (Section Data lbl) (Statics lbl []))
200 }
201
202
203 ---------------------------------------------------------------
204 -- Generating static stuff for algebraic data types
205 ---------------------------------------------------------------
206
207
208 cgEnumerationTyCon :: TyCon -> FCode ()
209 cgEnumerationTyCon tycon
210 = do dflags <- getDynFlags
211 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
212 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
213 (tagForCon dflags con)
214 | con <- tyConDataCons tycon]
215
216
217 cgDataCon :: DataCon -> FCode ()
218 -- Generate the entry code, info tables, and (for niladic constructor)
219 -- the static closure, for a constructor.
220 cgDataCon data_con
221 = do { dflags <- getDynFlags
222 ; let
223 (tot_wds, -- #ptr_wds + #nonptr_wds
224 ptr_wds) -- #ptr_wds
225 = mkVirtConstrSizes dflags arg_reps
226
227 nonptr_wds = tot_wds - ptr_wds
228
229 dyn_info_tbl =
230 mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
231
232 -- We're generating info tables, so we don't know and care about
233 -- what the actual arguments are. Using () here as the place holder.
234 arg_reps :: [NonVoid PrimRep]
235 arg_reps = [ NonVoid rep_ty
236 | ty <- dataConRepArgTys data_con
237 , rep_ty <- typePrimRep ty
238 , not (isVoidRep rep_ty) ]
239
240 ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
241 -- NB: the closure pointer is assumed *untagged* on
242 -- entry to a constructor. If the pointer is tagged,
243 -- then we should not be entering it. This assumption
244 -- is used in ldvEnter and when tagging the pointer to
245 -- return it.
246 -- NB 2: We don't set CC when entering data (WDP 94/06)
247 do { tickyEnterDynCon
248 ; ldvEnter (CmmReg nodeReg)
249 ; tickyReturnOldCon (length arg_reps)
250 ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
251 }
252 -- The case continuation code expects a tagged pointer
253 }
254
255 ---------------------------------------------------------------
256 -- Stuff to support splitting
257 ---------------------------------------------------------------
258
259 maybeExternaliseId :: DynFlags -> Id -> FCode Id
260 maybeExternaliseId dflags id
261 | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting]
262 -- in StgCmmMonad
263 isInternalName name = do { mod <- getModuleName
264 ; returnFC (setIdName id (externalise mod)) }
265 | otherwise = returnFC id
266 where
267 externalise mod = mkExternalName uniq mod new_occ loc
268 name = idName id
269 uniq = nameUnique name
270 new_occ = mkLocalOcc uniq (nameOccName name)
271 loc = nameSrcSpan name
272 -- We want to conjure up a name that can't clash with any
273 -- existing name. So we generate
274 -- Mod_$L243foo
275 -- where 243 is the unique.