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