Implement unboxed sum primitive type
[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 args
142
143 cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
144 = ASSERT(null fvs) -- There should be no free variables
145 cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
146
147
148 ---------------------------------------------------------------
149 -- Module initialisation code
150 ---------------------------------------------------------------
151
152 {- The module initialisation code looks like this, roughly:
153
154 FN(__stginit_Foo) {
155 JMP_(__stginit_Foo_1_p)
156 }
157
158 FN(__stginit_Foo_1_p) {
159 ...
160 }
161
162 We have one version of the init code with a module version and the
163 'way' attached to it. The version number helps to catch cases
164 where modules are not compiled in dependency order before being
165 linked: if a module has been compiled since any modules which depend on
166 it, then the latter modules will refer to a different version in their
167 init blocks and a link error will ensue.
168
169 The 'way' suffix helps to catch cases where modules compiled in different
170 ways are linked together (eg. profiled and non-profiled).
171
172 We provide a plain, unadorned, version of the module init code
173 which just jumps to the version with the label and way attached. The
174 reason for this is that when using foreign exports, the caller of
175 startupHaskell() must supply the name of the init function for the "top"
176 module in the program, and we don't want to require that this name
177 has the version and way info appended to it.
178
179 We initialise the module tree by keeping a work-stack,
180 * pointed to by Sp
181 * that grows downward
182 * Sp points to the last occupied slot
183 -}
184
185 mkModuleInit
186 :: CollectedCCs -- cost centre info
187 -> Module
188 -> HpcInfo
189 -> FCode ()
190
191 mkModuleInit cost_centre_info this_mod hpc_info
192 = do { initHpc this_mod hpc_info
193 ; initCostCentres cost_centre_info
194 -- For backwards compatibility: user code may refer to this
195 -- label for calling hs_add_root().
196 ; let lbl = mkPlainModuleInitLabel this_mod
197 ; emitDecl (CmmData (Section Data lbl) (Statics lbl []))
198 }
199
200
201 ---------------------------------------------------------------
202 -- Generating static stuff for algebraic data types
203 ---------------------------------------------------------------
204
205
206 cgEnumerationTyCon :: TyCon -> FCode ()
207 cgEnumerationTyCon tycon
208 = do dflags <- getDynFlags
209 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
210 [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
211 (tagForCon dflags con)
212 | con <- tyConDataCons tycon]
213
214
215 cgDataCon :: DataCon -> FCode ()
216 -- Generate the entry code, info tables, and (for niladic constructor)
217 -- the static closure, for a constructor.
218 cgDataCon data_con
219 = do { dflags <- getDynFlags
220 ; let
221 (tot_wds, -- #ptr_wds + #nonptr_wds
222 ptr_wds, -- #ptr_wds
223 arg_things) = mkVirtConstrOffsets dflags arg_reps
224
225 nonptr_wds = tot_wds - ptr_wds
226
227 sta_info_tbl = mkDataConInfoTable dflags data_con True ptr_wds nonptr_wds
228 dyn_info_tbl = mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
229
230 emit_info info_tbl ticky_code
231 = emitClosureAndInfoTable info_tbl NativeDirectCall []
232 $ mk_code ticky_code
233
234 mk_code ticky_code
235 = -- NB: the closure pointer is assumed *untagged* on
236 -- entry to a constructor. If the pointer is tagged,
237 -- then we should not be entering it. This assumption
238 -- is used in ldvEnter and when tagging the pointer to
239 -- return it.
240 -- NB 2: We don't set CC when entering data (WDP 94/06)
241 do { _ <- ticky_code
242 ; ldvEnter (CmmReg nodeReg)
243 ; tickyReturnOldCon (length arg_things)
244 ; void $ emitReturn [CmmExprArg (cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con))]
245 }
246 -- The case continuation code expects a tagged pointer
247
248 arg_reps :: [(PrimRep, UnaryType)]
249 arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con
250 , rep_ty <- repTypeArgs ty]
251
252 -- Dynamic closure code for non-nullary constructors only
253 ; when (not (isNullaryRepDataCon data_con))
254 (emit_info dyn_info_tbl tickyEnterDynCon)
255
256 -- Dynamic-Closure first, to reduce forward references
257 ; emit_info sta_info_tbl tickyEnterStaticCon }
258
259
260 ---------------------------------------------------------------
261 -- Stuff to support splitting
262 ---------------------------------------------------------------
263
264 maybeExternaliseId :: DynFlags -> Id -> FCode Id
265 maybeExternaliseId dflags id
266 | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting]
267 -- in StgCmmMonad
268 isInternalName name = do { mod <- getModuleName
269 ; returnFC (setIdName id (externalise mod)) }
270 | otherwise = returnFC id
271 where
272 externalise mod = mkExternalName uniq mod new_occ loc
273 name = idName id
274 uniq = nameUnique name
275 new_occ = mkLocalOcc uniq (nameOccName name)
276 loc = nameSrcSpan name
277 -- We want to conjure up a name that can't clash with any
278 -- existing name. So we generate
279 -- Mod_$L243foo
280 -- where 243 is the unique.