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