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