s/StgArrWords/StgArrBytes/
[ghc.git] / compiler / codeGen / StgCmmCon.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Stg to C--: code generation for constructors
6 --
7 -- This module provides the support code for StgCmm to deal with with
8 -- constructors on the RHSs of let(rec)s.
9 --
10 -- (c) The University of Glasgow 2004-2006
11 --
12 -----------------------------------------------------------------------------
13
14 module StgCmmCon (
15 cgTopRhsCon, buildDynCon, bindConArgs
16 ) where
17
18 #include "HsVersions.h"
19
20 import StgSyn
21 import CoreSyn ( AltCon(..) )
22
23 import StgCmmMonad
24 import StgCmmEnv
25 import StgCmmHeap
26 import StgCmmLayout
27 import StgCmmUtils
28 import StgCmmClosure
29 import StgCmmProf ( curCCS )
30
31 import CmmExpr
32 import CLabel
33 import MkGraph
34 import SMRep
35 import CostCentre
36 import Module
37 import DataCon
38 import DynFlags
39 import FastString
40 import Id
41 import Literal
42 import PrelInfo
43 import Outputable
44 import Platform
45 import Util
46
47 import Control.Monad
48 import Data.Char
49
50
51
52 ---------------------------------------------------------------
53 -- Top-level constructors
54 ---------------------------------------------------------------
55
56 cgTopRhsCon :: DynFlags
57 -> Id -- Name of thing bound to this RHS
58 -> DataCon -- Id
59 -> [StgArg] -- Args
60 -> (CgIdInfo, FCode ())
61 cgTopRhsCon dflags id con args =
62 let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
63 in (id_info, gen_code)
64 where
65 name = idName id
66 caffy = idCafInfo id -- any stgArgHasCafRefs args
67 closure_label = mkClosureLabel name caffy
68
69 gen_code =
70 do { this_mod <- getModuleName
71 ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
72 -- Windows DLLs have a problem with static cross-DLL refs.
73 ASSERT( not (isDllConApp dflags this_mod con args) ) return ()
74 ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
75
76 -- LAY IT OUT
77 ; let
78 (tot_wds, -- #ptr_wds + #nonptr_wds
79 ptr_wds, -- #ptr_wds
80 nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)
81
82 nonptr_wds = tot_wds - ptr_wds
83
84 -- we're not really going to emit an info table, so having
85 -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
86 -- needs to poke around inside it.
87 info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
88
89 get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
90 ; return lit }
91
92 ; payload <- mapM get_lit nv_args_w_offsets
93 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
94 -- NB2: all the amodes should be Lits!
95
96 ; let closure_rep = mkStaticClosureFields
97 dflags
98 info_tbl
99 dontCareCCS -- Because it's static data
100 caffy -- Has CAF refs
101 payload
102
103 -- BUILD THE OBJECT
104 ; emitDataLits closure_label closure_rep
105
106 ; return () }
107
108
109 ---------------------------------------------------------------
110 -- Lay out and allocate non-top-level constructors
111 ---------------------------------------------------------------
112
113 buildDynCon :: Id -- Name of the thing to which this constr will
114 -- be bound
115 -> Bool -- is it genuinely bound to that name, or just for profiling?
116 -> CostCentreStack -- Where to grab cost centre from;
117 -- current CCS if currentOrSubsumedCCS
118 -> DataCon -- The data constructor
119 -> [StgArg] -- Its args
120 -> FCode (CgIdInfo, FCode CmmAGraph)
121 -- Return details about how to find it and initialization code
122 buildDynCon binder actually_bound cc con args
123 = do dflags <- getDynFlags
124 buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
125
126
127 buildDynCon' :: DynFlags
128 -> Platform
129 -> Id -> Bool
130 -> CostCentreStack
131 -> DataCon
132 -> [StgArg]
133 -> FCode (CgIdInfo, FCode CmmAGraph)
134
135 {- We used to pass a boolean indicating whether all the
136 args were of size zero, so we could use a static
137 constructor; but I concluded that it just isn't worth it.
138 Now I/O uses unboxed tuples there just aren't any constructors
139 with all size-zero args.
140
141 The reason for having a separate argument, rather than looking at
142 the addr modes of the args is that we may be in a "knot", and
143 premature looking at the args will cause the compiler to black-hole!
144 -}
145
146
147 -------- buildDynCon': Nullary constructors --------------
148 -- First we deal with the case of zero-arity constructors. They
149 -- will probably be unfolded, so we don't expect to see this case much,
150 -- if at all, but it does no harm, and sets the scene for characters.
151 --
152 -- In the case of zero-arity constructors, or, more accurately, those
153 -- which have exclusively size-zero (VoidRep) args, we generate no code
154 -- at all.
155
156 buildDynCon' dflags _ binder _ _cc con []
157 = return (litIdInfo dflags binder (mkConLFInfo con)
158 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
159 return mkNop)
160
161 -------- buildDynCon': Charlike and Intlike constructors -----------
162 {- The following three paragraphs about @Char@-like and @Int@-like
163 closures are obsolete, but I don't understand the details well enough
164 to properly word them, sorry. I've changed the treatment of @Char@s to
165 be analogous to @Int@s: only a subset is preallocated, because @Char@
166 has now 31 bits. Only literals are handled here. -- Qrczak
167
168 Now for @Char@-like closures. We generate an assignment of the
169 address of the closure to a temporary. It would be possible simply to
170 generate no code, and record the addressing mode in the environment,
171 but we'd have to be careful if the argument wasn't a constant --- so
172 for simplicity we just always asssign to a temporary.
173
174 Last special case: @Int@-like closures. We only special-case the
175 situation in which the argument is a literal in the range
176 @mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can
177 work with any old argument, but for @Int@-like ones the argument has
178 to be a literal. Reason: @Char@ like closures have an argument type
179 which is guaranteed in range.
180
181 Because of this, we use can safely return an addressing mode.
182
183 We don't support this optimisation when compiling into Windows DLLs yet
184 because they don't support cross package data references well.
185 -}
186
187 buildDynCon' dflags platform binder _ _cc con [arg]
188 | maybeIntLikeCon con
189 , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
190 , StgLitArg (MachInt val) <- arg
191 , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
192 , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
193 = do { let intlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_INTLIKE")
194 val_int = fromIntegral val :: Int
195 offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
196 -- INTLIKE closures consist of a header and one word payload
197 intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
198 ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
199 , return mkNop) }
200
201 buildDynCon' dflags platform binder _ _cc con [arg]
202 | maybeCharLikeCon con
203 , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
204 , StgLitArg (MachChar val) <- arg
205 , let val_int = ord val :: Int
206 , val_int <= mAX_CHARLIKE dflags
207 , val_int >= mIN_CHARLIKE dflags
208 = do { let charlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_CHARLIKE")
209 offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
210 -- CHARLIKE closures consist of a header and one word payload
211 charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
212 ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
213 , return mkNop) }
214
215 -------- buildDynCon': the general case -----------
216 buildDynCon' dflags _ binder actually_bound ccs con args
217 = do { (id_info, reg) <- rhsIdInfo binder lf_info
218 ; return (id_info, gen_code reg)
219 }
220 where
221 lf_info = mkConLFInfo con
222
223 gen_code reg
224 = do { let (tot_wds, ptr_wds, args_w_offsets)
225 = mkVirtConstrOffsets dflags (addArgReps args)
226 -- No void args in args_w_offsets
227 nonptr_wds = tot_wds - ptr_wds
228 info_tbl = mkDataConInfoTable dflags con False
229 ptr_wds nonptr_wds
230 ; let ticky_name | actually_bound = Just binder
231 | otherwise = Nothing
232
233 ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
234 use_cc blame_cc args_w_offsets
235 ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
236 where
237 use_cc -- cost-centre to stick in the object
238 | isCurrentCCS ccs = curCCS
239 | otherwise = panic "buildDynCon: non-current CCS not implemented"
240
241 blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
242
243
244 ---------------------------------------------------------------
245 -- Binding constructor arguments
246 ---------------------------------------------------------------
247
248 bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg]
249 -- bindConArgs is called from cgAlt of a case
250 -- (bindConArgs con args) augments the environment with bindings for the
251 -- binders args, assuming that we have just returned from a 'case' which
252 -- found a con
253 bindConArgs (DataAlt con) base args
254 = ASSERT(not (isUnboxedTupleCon con))
255 do dflags <- getDynFlags
256 let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
257 tag = tagForCon dflags con
258
259 -- The binding below forces the masking out of the tag bits
260 -- when accessing the constructor field.
261 bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
262 bind_arg (arg, offset)
263 = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
264 bindArgToReg arg
265 mapM bind_arg args_w_offsets
266
267 bindConArgs _other_con _base args
268 = ASSERT( null args ) return []
269