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