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