87680087764f3aa094dce3fc75bc081a11876f82
[ghc.git] / compiler / codeGen / CgCon.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
4 %
5 \section[CgCon]{Code generation for constructors}
6
7 This module provides the support code for @StgToAbstractC@ to deal
8 with {\em constructors} on the RHSs of let(rec)s.  See also
9 @CgClosure@, which deals with closures.
10
11 \begin{code}
12 module CgCon (
13         cgTopRhsCon, buildDynCon,
14         bindConArgs, bindUnboxedTupleComponents,
15         cgReturnDataCon,
16         cgTyCon
17     ) where
18
19 #include "HsVersions.h"
20
21 import CgMonad
22 import StgSyn
23
24 import CgBindery
25 import CgStackery
26 import CgUtils
27 import CgCallConv
28 import CgHeapery
29 import CgTailCall
30 import CgProf
31 import CgTicky
32 import CgInfoTbls
33 import CLabel
34 import ClosureInfo
35 import OldCmmUtils
36 import OldCmm
37 import SMRep
38 import CostCentre
39 import Constants
40 import TyCon
41 import DataCon
42 import Id
43 import IdInfo
44 import Type
45 import PrelInfo
46 import Outputable
47 import ListSetOps
48 import Util
49 import Module
50 import FastString
51 import StaticFlags
52 \end{code}
53
54
55 %************************************************************************
56 %*                                                                      *
57 \subsection[toplevel-constructors]{Top-level constructors}
58 %*                                                                      *
59 %************************************************************************
60
61 \begin{code}
62 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
63             -> DataCon          -- Id
64             -> [StgArg]         -- Args
65             -> FCode (Id, CgIdInfo)
66 cgTopRhsCon id con args
67   = do { 
68 #if mingw32_TARGET_OS
69         -- Windows DLLs have a problem with static cross-DLL refs.
70         ; this_pkg <- getThisPackage
71         ; ASSERT( not (isDllConApp this_pkg con args) ) return ()
72 #endif
73         ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
74
75         -- LAY IT OUT
76         ; amodes <- getArgAmodes args
77
78         ; let
79             name          = idName id
80             lf_info       = mkConLFInfo con
81             closure_label = mkClosureLabel name $ idCafInfo id
82             caffy         = any stgArgHasCafRefs args
83             (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
84             closure_rep = mkStaticClosureFields
85                              closure_info
86                              dontCareCCS                -- Because it's static data
87                              caffy                      -- Has CAF refs
88                              payload
89
90             payload = map get_lit amodes_w_offsets      
91             get_lit (CmmLit lit, _offset) = lit
92             get_lit other = pprPanic "CgCon.get_lit" (ppr other)
93                 -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
94                 -- NB2: all the amodes should be Lits!
95
96                 -- BUILD THE OBJECT
97         ; emitDataLits closure_label closure_rep
98
99                 -- RETURN
100         ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) }
101 \end{code}
102
103 %************************************************************************
104 %*                                                                      *
105 %* non-top-level constructors                                           *
106 %*                                                                      *
107 %************************************************************************
108 \subsection[code-for-constructors]{The code for constructors}
109
110 \begin{code}
111 buildDynCon :: Id                 -- Name of the thing to which this constr will
112                                   -- be bound
113             -> CostCentreStack    -- Where to grab cost centre from;
114                                   -- current CCS if currentOrSubsumedCCS
115             -> DataCon            -- The data constructor
116             -> [(CgRep,CmmExpr)] -- Its args
117             -> FCode CgIdInfo     -- Return details about how to find it
118
119 -- We used to pass a boolean indicating whether all the
120 -- args were of size zero, so we could use a static
121 -- construtor; but I concluded that it just isn't worth it.
122 -- Now I/O uses unboxed tuples there just aren't any constructors
123 -- with all size-zero args.
124 --
125 -- The reason for having a separate argument, rather than looking at
126 -- the addr modes of the args is that we may be in a "knot", and
127 -- premature looking at the args will cause the compiler to black-hole!
128 \end{code}
129
130 First we deal with the case of zero-arity constructors.  Now, they
131 will probably be unfolded, so we don't expect to see this case much,
132 if at all, but it does no harm, and sets the scene for characters.
133
134 In the case of zero-arity constructors, or, more accurately, those
135 which have exclusively size-zero (VoidRep) args, we generate no code
136 at all.
137
138 \begin{code}
139 buildDynCon binder _ con []
140   = returnFC (taggedStableIdInfo binder
141                            (mkLblExpr (mkClosureLabel (dataConName con)
142                                       (idCafInfo binder)))
143                            (mkConLFInfo con)
144                            con)
145 \end{code}
146
147 The following three paragraphs about @Char@-like and @Int@-like
148 closures are obsolete, but I don't understand the details well enough
149 to properly word them, sorry. I've changed the treatment of @Char@s to
150 be analogous to @Int@s: only a subset is preallocated, because @Char@
151 has now 31 bits. Only literals are handled here. -- Qrczak
152
153 Now for @Char@-like closures.  We generate an assignment of the
154 address of the closure to a temporary.  It would be possible simply to
155 generate no code, and record the addressing mode in the environment,
156 but we'd have to be careful if the argument wasn't a constant --- so
157 for simplicity we just always asssign to a temporary.
158
159 Last special case: @Int@-like closures.  We only special-case the
160 situation in which the argument is a literal in the range
161 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
162 work with any old argument, but for @Int@-like ones the argument has
163 to be a literal.  Reason: @Char@ like closures have an argument type
164 which is guaranteed in range.
165
166 Because of this, we use can safely return an addressing mode.
167
168 We don't support this optimisation when compiling into Windows DLLs yet
169 because they don't support cross package data references well.
170
171 \begin{code}
172
173
174 buildDynCon binder _ con [arg_amode]
175   | maybeIntLikeCon con 
176 #if defined(mingw32_TARGET_OS)
177   , not opt_PIC
178 #endif
179   , (_, CmmLit (CmmInt val _)) <- arg_amode
180   , let val_int = (fromIntegral val) :: Int
181   , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
182   = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
183               offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
184                 -- INTLIKE closures consist of a header and one word payload
185               intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
186         ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) }
187
188 buildDynCon binder _ con [arg_amode]
189   | maybeCharLikeCon con 
190 #if defined(mingw32_TARGET_OS)
191   , not opt_PIC
192 #endif
193   , (_, CmmLit (CmmInt val _)) <- arg_amode
194   , let val_int = (fromIntegral val) :: Int
195   , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
196   = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
197               offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
198                 -- CHARLIKE closures consist of a header and one word payload
199               charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
200         ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) }
201
202 \end{code}
203
204 Now the general case.
205
206 \begin{code}
207 buildDynCon binder ccs con args
208   = do  { 
209         ; let
210             (closure_info, amodes_w_offsets) = layOutDynConstr con args
211
212         ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
213         ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) }
214   where
215     lf_info = mkConLFInfo con
216
217     use_cc      -- cost-centre to stick in the object
218       | currentOrSubsumedCCS ccs = curCCS
219       | otherwise                = CmmLit (mkCCostCentreStack ccs)
220
221     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
222 \end{code}
223
224
225 %************************************************************************
226 %*                                                                      *
227 %* constructor-related utility function:                                *
228 %*              bindConArgs is called from cgAlt of a case              *
229 %*                                                                      *
230 %************************************************************************
231 \subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
232
233 @bindConArgs@ $con args$ augments the environment with bindings for the
234 binders $args$, assuming that we have just returned from a @case@ which
235 found a $con$.
236
237 \begin{code}
238 bindConArgs :: DataCon -> [Id] -> Code
239 bindConArgs con args
240   = do
241        let
242           -- The binding below forces the masking out of the tag bits
243           -- when accessing the constructor field.
244           bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con)
245           (_, args_w_offsets)    = layOutDynConstr con (addIdReps args)
246         --
247        ASSERT(not (isUnboxedTupleCon con)) return ()
248        mapCs bind_arg args_w_offsets
249 \end{code}
250
251 Unboxed tuples are handled slightly differently - the object is
252 returned in registers and on the stack instead of the heap.
253
254 \begin{code}
255 bindUnboxedTupleComponents
256         :: [Id]                         -- Args
257         -> FCode ([(Id,GlobalReg)],     -- Regs assigned
258                   WordOff,              -- Number of pointer stack slots
259                   WordOff,              -- Number of non-pointer stack slots
260                   VirtualSpOffset)      -- Offset of return address slot
261                                         -- (= realSP on entry)
262
263 bindUnboxedTupleComponents args
264  =  do  {   
265           vsp <- getVirtSp
266         ; rsp <- getRealSp
267
268            -- Assign as many components as possible to registers
269         ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
270
271                 -- Separate the rest of the args into pointers and non-pointers
272               (ptr_args, nptr_args) = separateByPtrFollowness stk_args
273   
274                 -- Allocate the rest on the stack
275                 -- The real SP points to the return address, above which any 
276                 -- leftover unboxed-tuple components will be allocated
277               (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets rsp    ptr_args
278               (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args
279               ptrs  = ptr_sp  - rsp
280               nptrs = nptr_sp - ptr_sp
281
282             -- The stack pointer points to the last stack-allocated component
283         ; setRealAndVirtualSp nptr_sp
284
285             -- We have just allocated slots starting at real SP + 1, and set the new
286             -- virtual SP to the topmost allocated slot.  
287             -- If the virtual SP started *below* the real SP, we've just jumped over
288             -- some slots that won't be in the free-list, so put them there
289             -- This commonly happens because we've freed the return-address slot
290             -- (trimming back the virtual SP), but the real SP still points to that slot
291         ; freeStackSlots [vsp+1,vsp+2 .. rsp]
292
293         ; bindArgsToRegs reg_args
294         ; bindArgsToStack ptr_offsets
295         ; bindArgsToStack nptr_offsets
296
297         ; returnFC (reg_args, ptrs, nptrs, rsp) }
298 \end{code}
299
300 %************************************************************************
301 %*                                                                      *
302         Actually generate code for a constructor return
303 %*                                                                      *
304 %************************************************************************
305
306
307 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
308 sure the @amodes@ passed don't conflict with each other.
309 \begin{code}
310 cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
311
312 cgReturnDataCon con amodes
313   | isUnboxedTupleCon con = returnUnboxedTuple amodes
314       -- when profiling we can't shortcut here, we have to enter the closure
315       -- for it to be marked as "used" for LDV profiling.
316   | opt_SccProfilingOn    = build_it_then enter_it
317   | otherwise
318   = ASSERT( amodes `lengthIs` dataConRepArity con )
319     do  { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
320         ; case sequel of
321             CaseAlts _ (Just (alts, deflt_lbl)) bndr
322               ->    -- Ho! We know the constructor so we can
323                     -- go straight to the right alternative
324                  case assocMaybe alts (dataConTagZ con) of {
325                     Just join_lbl -> build_it_then (jump_to join_lbl);
326                     Nothing
327                         -- Special case!  We're returning a constructor to the default case
328                         -- of an enclosing case.  For example:
329                         --
330                         --      case (case e of (a,b) -> C a b) of
331                         --        D x -> ...
332                         --        y   -> ...<returning here!>...
333                         --
334                         -- In this case,
335                         --      if the default is a non-bind-default (ie does not use y),
336                         --      then we should simply jump to the default join point;
337     
338                         | isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
339                         | otherwise         -> build_it_then (jump_to deflt_lbl) }
340     
341             _otherwise  -- The usual case
342               -> build_it_then emitReturnInstr
343         }
344   where
345     enter_it    = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
346                            CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg))) [] ]
347     jump_to lbl = stmtC (CmmJump (CmmLit lbl) [])
348     build_it_then return_code
349       = do {    -- BUILD THE OBJECT IN THE HEAP
350                 -- The first "con" says that the name bound to this
351                 -- closure is "con", which is a bit of a fudge, but it only
352                 -- affects profiling
353
354                 -- This Id is also used to get a unique for a
355                 -- temporary variable, if the closure is a CHARLIKE.
356                 -- funnily enough, this makes the unique always come
357                 -- out as '54' :-)
358              tickyReturnNewCon (length amodes)
359            ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes
360            ; amode <- idInfoToAmode idinfo
361            ; checkedAbsC (CmmAssign nodeReg amode)
362            ; performReturn return_code }
363 \end{code}
364
365
366 %************************************************************************
367 %*                                                                      *
368         Generating static stuff for algebraic data types
369 %*                                                                      *
370 %************************************************************************
371
372         [These comments are rather out of date]
373
374 \begin{tabular}{lll}
375 Info tbls &      Macro  &            Kind of constructor \\
376 \hline
377 info & @CONST_INFO_TABLE@&    Zero arity (no info -- compiler uses static closure)\\
378 info & @CHARLIKE_INFO_TABLE@& Charlike   (no info -- compiler indexes fixed array)\\
379 info & @INTLIKE_INFO_TABLE@&  Intlike; the one macro generates both info tbls\\
380 info & @SPEC_INFO_TABLE@&     SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
381 info & @GEN_INFO_TABLE@&      GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
382 \end{tabular}
383
384 Possible info tables for constructor con:
385
386 \begin{description}
387 \item[@_con_info@:]
388 Used for dynamically let(rec)-bound occurrences of
389 the constructor, and for updates.  For constructors
390 which are int-like, char-like or nullary, when GC occurs,
391 the closure tries to get rid of itself.
392
393 \item[@_static_info@:]
394 Static occurrences of the constructor
395 macro: @STATIC_INFO_TABLE@.
396 \end{description}
397
398 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
399 it's place is taken by the top level defn of the constructor.
400
401 For charlike and intlike closures there is a fixed array of static
402 closures predeclared.
403
404 \begin{code}
405 cgTyCon :: TyCon -> FCode [Cmm]  -- each constructor gets a separate Cmm
406 cgTyCon tycon
407   = do  { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
408
409             -- Generate a table of static closures for an enumeration type
410             -- Put the table after the data constructor decls, because the
411             -- datatype closure table (for enumeration types)
412             -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
413             -- Note that the closure pointers are tagged.
414
415             -- XXX comment says to put table after constructor decls, but
416             -- code appears to put it before --- NR 16 Aug 2007
417         ; extra <- 
418            if isEnumerationTyCon tycon then do
419                 tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
420                            [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con)
421                            | con <- tyConDataCons tycon])
422                 return [tbl]
423            else
424                 return []
425
426         ; return (extra ++ constrs)
427     }
428 \end{code}
429
430 Generate the entry code, info tables, and (for niladic constructor) the
431 static closure, for a constructor.
432
433 \begin{code}
434 cgDataCon :: DataCon -> Code
435 cgDataCon data_con
436   = do  {     -- Don't need any dynamic closure code for zero-arity constructors
437
438         ; let
439             -- To allow the debuggers, interpreters, etc to cope with
440             -- static data structures (ie those built at compile
441             -- time), we take care that info-table contains the
442             -- information we need.
443             (static_cl_info, _) = 
444                 layOutStaticConstr data_con arg_reps
445
446             (dyn_cl_info, arg_things) = 
447                 layOutDynConstr    data_con arg_reps
448
449             emit_info cl_info ticky_code
450                 = do { code_blks <- getCgStmts the_code
451                      ; emitClosureCodeAndInfoTable cl_info [] code_blks }
452                 where
453                   the_code = do { _ <- ticky_code
454                                 ; ldvEnter (CmmReg nodeReg)
455                                 ; body_code }
456
457             arg_reps :: [(CgRep, Type)]
458             arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
459
460             body_code = do {    
461                         -- NB: We don't set CC when entering data (WDP 94/06)
462                              tickyReturnOldCon (length arg_things)
463                            -- The case continuation code is expecting a tagged pointer
464                            ; stmtC (CmmAssign nodeReg
465                                               (tagCons data_con (CmmReg nodeReg)))
466                            ; performReturn emitReturnInstr }
467                                 -- noStmts: Ptr to thing already in Node
468
469         ; whenC (not (isNullaryRepDataCon data_con))
470                 (emit_info dyn_cl_info tickyEnterDynCon)
471
472                 -- Dynamic-Closure first, to reduce forward references
473         ; emit_info static_cl_info tickyEnterStaticCon }
474 \end{code}