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