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