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