368bc534838b219d30cc8fc6431eba76b23213ab
[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 Constants
35 import DataCon
36 import FastString
37 import Id
38 import Literal
39 import PrelInfo
40 import Outputable
41 import Util ( lengthIs )
42
43 import Data.Char
44
45 #if defined(mingw32_TARGET_OS)
46 import StaticFlags ( opt_PIC )
47 #endif
48
49
50 ---------------------------------------------------------------
51 -- Top-level constructors
52 ---------------------------------------------------------------
53
54 cgTopRhsCon :: Id -- Name of thing bound to this RHS
55 -> DataCon -- Id
56 -> [StgArg] -- Args
57 -> FCode CgIdInfo
58 cgTopRhsCon id con args
59 = do {
60 #if mingw32_TARGET_OS
61 -- Windows DLLs have a problem with static cross-DLL refs.
62 ; this_pkg <- getThisPackage
63 ; ASSERT( not (isDllConApp this_pkg con args) ) return ()
64 #endif
65 ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
66
67 -- LAY IT OUT
68 ; let
69 name = idName id
70 lf_info = mkConLFInfo con
71 closure_label = mkClosureLabel name $ idCafInfo id
72 caffy = any stgArgHasCafRefs args
73 (closure_info, nv_args_w_offsets)
74 = layOutStaticConstr con (addArgReps args)
75
76 get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
77 ; return lit }
78
79 ; payload <- mapM get_lit nv_args_w_offsets
80 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
81 -- NB2: all the amodes should be Lits!
82
83 ; let closure_rep = mkStaticClosureFields
84 closure_info
85 dontCareCCS -- Because it's static data
86 caffy -- Has CAF refs
87 payload
88
89 -- BUILD THE OBJECT
90 ; emitDataLits closure_label closure_rep
91
92 -- RETURN
93 ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
94
95
96 ---------------------------------------------------------------
97 -- Lay out and allocate non-top-level constructors
98 ---------------------------------------------------------------
99
100 buildDynCon :: Id -- Name of the thing to which this constr will
101 -- be bound
102 -> CostCentreStack -- Where to grab cost centre from;
103 -- current CCS if currentOrSubsumedCCS
104 -> DataCon -- The data constructor
105 -> [StgArg] -- Its args
106 -> FCode (CgIdInfo, CmmAGraph)
107 -- Return details about how to find it and initialization code
108
109 {- We used to pass a boolean indicating whether all the
110 args were of size zero, so we could use a static
111 construtor; but I concluded that it just isn't worth it.
112 Now I/O uses unboxed tuples there just aren't any constructors
113 with all size-zero args.
114
115 The reason for having a separate argument, rather than looking at
116 the addr modes of the args is that we may be in a "knot", and
117 premature looking at the args will cause the compiler to black-hole!
118 -}
119
120
121 -------- buildDynCon: Nullary constructors --------------
122 -- First we deal with the case of zero-arity constructors. They
123 -- will probably be unfolded, so we don't expect to see this case much,
124 -- if at all, but it does no harm, and sets the scene for characters.
125 --
126 -- In the case of zero-arity constructors, or, more accurately, those
127 -- which have exclusively size-zero (VoidRep) args, we generate no code
128 -- at all.
129
130 buildDynCon binder _cc con []
131 = return (litIdInfo binder (mkConLFInfo con)
132 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
133 mkNop)
134
135 -------- buildDynCon: Charlike and Intlike constructors -----------
136 {- The following three paragraphs about @Char@-like and @Int@-like
137 closures are obsolete, but I don't understand the details well enough
138 to properly word them, sorry. I've changed the treatment of @Char@s to
139 be analogous to @Int@s: only a subset is preallocated, because @Char@
140 has now 31 bits. Only literals are handled here. -- Qrczak
141
142 Now for @Char@-like closures. We generate an assignment of the
143 address of the closure to a temporary. It would be possible simply to
144 generate no code, and record the addressing mode in the environment,
145 but we'd have to be careful if the argument wasn't a constant --- so
146 for simplicity we just always asssign to a temporary.
147
148 Last special case: @Int@-like closures. We only special-case the
149 situation in which the argument is a literal in the range
150 @mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can
151 work with any old argument, but for @Int@-like ones the argument has
152 to be a literal. Reason: @Char@ like closures have an argument type
153 which is guaranteed in range.
154
155 Because of this, we use can safely return an addressing mode.
156
157 We don't support this optimisation when compiling into Windows DLLs yet
158 because they don't support cross package data references well.
159 -}
160
161 buildDynCon binder _cc con [arg]
162 | maybeIntLikeCon con
163 #if defined(mingw32_TARGET_OS)
164 , not opt_PIC
165 #endif
166 , StgLitArg (MachInt val) <- arg
167 , val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer!
168 , val >= fromIntegral mIN_INTLIKE -- ...ditto...
169 = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
170 val_int = fromIntegral val :: Int
171 offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
172 -- INTLIKE closures consist of a header and one word payload
173 intlike_amode = cmmLabelOffW intlike_lbl offsetW
174 ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
175
176 buildDynCon binder _cc con [arg]
177 | maybeCharLikeCon con
178 #if defined(mingw32_TARGET_OS)
179 , not opt_PIC
180 #endif
181 , StgLitArg (MachChar val) <- arg
182 , let val_int = ord val :: Int
183 , val_int <= mAX_CHARLIKE
184 , val_int >= mIN_CHARLIKE
185 = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
186 offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
187 -- CHARLIKE closures consist of a header and one word payload
188 charlike_amode = cmmLabelOffW charlike_lbl offsetW
189 ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
190
191 -------- buildDynCon: the general case -----------
192 buildDynCon binder ccs con args
193 = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
194 -- No void args in args_w_offsets
195 ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
196 ; regIdInfo binder lf_info tmp init }
197 where
198 lf_info = mkConLFInfo con
199
200 use_cc -- cost-centre to stick in the object
201 | currentOrSubsumedCCS ccs = curCCS
202 | otherwise = CmmLit (mkCCostCentreStack ccs)
203
204 blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
205
206
207 ---------------------------------------------------------------
208 -- Binding constructor arguments
209 ---------------------------------------------------------------
210
211 bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg]
212 -- bindConArgs is called from cgAlt of a case
213 -- (bindConArgs con args) augments the environment with bindings for the
214 -- binders args, assuming that we have just returned from a 'case' which
215 -- found a con
216 bindConArgs (DataAlt con) base args
217 = ASSERT(not (isUnboxedTupleCon con))
218 mapM bind_arg args_w_offsets
219 where
220 (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
221
222 tag = tagForCon con
223
224 -- The binding below forces the masking out of the tag bits
225 -- when accessing the constructor field.
226 bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
227 bind_arg (arg, offset)
228 = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
229 ; bindArgToReg arg }
230
231 bindConArgs _other_con _base args
232 = ASSERT( null args ) return []
233
234
235