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