Add a class HasDynFlags(getDynFlags)
[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 import StaticFlags
54
55 import Control.Monad
56 \end{code}
57
58
59 %************************************************************************
60 %*                                                                      *
61 \subsection[toplevel-constructors]{Top-level constructors}
62 %*                                                                      *
63 %************************************************************************
64
65 \begin{code}
66 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
67             -> DataCon          -- Id
68             -> [StgArg]         -- Args
69             -> FCode (Id, CgIdInfo)
70 cgTopRhsCon id con args
71   = do { dflags <- getDynFlags
72         ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
73               -- Windows DLLs have a problem with static cross-DLL refs.
74               ASSERT( not (isDllConApp dflags con args) ) return ()
75         ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
76
77         -- LAY IT OUT
78         ; amodes <- getArgAmodes args
79
80         ; let
81             platform = targetPlatform dflags
82             name          = idName id
83             lf_info       = mkConLFInfo con
84             closure_label = mkClosureLabel name $ idCafInfo id
85             caffy         = any stgArgHasCafRefs args
86             (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
87             closure_rep = mkStaticClosureFields
88                              closure_info
89                              dontCareCCS                -- Because it's static data
90                              caffy                      -- Has CAF refs
91                              payload
92
93             payload = map get_lit amodes_w_offsets
94             get_lit (CmmLit lit, _offset) = lit
95             get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other)
96                 -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
97                 -- NB2: all the amodes should be Lits!
98
99                 -- BUILD THE OBJECT
100         ; emitDataLits closure_label closure_rep
101
102                 -- RETURN
103         ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) }
104 \end{code}
105
106 %************************************************************************
107 %*                                                                      *
108 %* non-top-level constructors                                           *
109 %*                                                                      *
110 %************************************************************************
111 \subsection[code-for-constructors]{The code for constructors}
112
113 \begin{code}
114 buildDynCon :: Id                 -- Name of the thing to which this constr will
115                                   -- be bound
116             -> CostCentreStack    -- Where to grab cost centre from;
117                                   -- current CCS if currentOrSubsumedCCS
118             -> DataCon            -- The data constructor
119             -> [(CgRep,CmmExpr)] -- Its args
120             -> FCode CgIdInfo     -- Return details about how to find it
121 buildDynCon binder ccs con args
122     = do dflags <- getDynFlags
123          buildDynCon' (targetPlatform dflags) binder ccs con args
124
125 buildDynCon' :: 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' platform binder _ con [arg_amode]
188   | maybeIntLikeCon con
189   , platformOS platform /= OSMinGW32 || not opt_PIC
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 + 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' platform binder _ con [arg_amode]
200   | maybeCharLikeCon con
201   , platformOS platform /= OSMinGW32 || not opt_PIC
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 + 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' _ binder ccs con args
217   = do  {
218         ; let
219             (closure_info, amodes_w_offsets) = layOutDynConstr 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
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 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           vsp <- getVirtSp
275         ; rsp <- getRealSp
276
277            -- Assign as many components as possible to registers
278         ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
279
280                 -- Separate the rest of the args into pointers and non-pointers
281               (ptr_args, nptr_args) = separateByPtrFollowness stk_args
282
283                 -- Allocate the rest on the stack
284                 -- The real SP points to the return address, above which any
285                 -- leftover unboxed-tuple components will be allocated
286               (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets rsp    ptr_args
287               (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args
288               ptrs  = ptr_sp  - rsp
289               nptrs = nptr_sp - ptr_sp
290
291             -- The stack pointer points to the last stack-allocated component
292         ; setRealAndVirtualSp nptr_sp
293
294             -- We have just allocated slots starting at real SP + 1, and set the new
295             -- virtual SP to the topmost allocated slot.
296             -- If the virtual SP started *below* the real SP, we've just jumped over
297             -- some slots that won't be in the free-list, so put them there
298             -- This commonly happens because we've freed the return-address slot
299             -- (trimming back the virtual SP), but the real SP still points to that slot
300         ; freeStackSlots [vsp+1,vsp+2 .. rsp]
301
302         ; bindArgsToRegs reg_args
303         ; bindArgsToStack ptr_offsets
304         ; bindArgsToStack nptr_offsets
305
306         ; returnFC (reg_args, ptrs, nptrs, rsp) }
307 \end{code}
308
309 %************************************************************************
310 %*                                                                      *
311         Actually generate code for a constructor return
312 %*                                                                      *
313 %************************************************************************
314
315
316 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
317 sure the @amodes@ passed don't conflict with each other.
318 \begin{code}
319 cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
320
321 cgReturnDataCon con amodes
322   | isUnboxedTupleCon con = returnUnboxedTuple amodes
323       -- when profiling we can't shortcut here, we have to enter the closure
324       -- for it to be marked as "used" for LDV profiling.
325   | opt_SccProfilingOn    = build_it_then enter_it
326   | otherwise
327   = ASSERT( amodes `lengthIs` dataConRepArity con )
328     do  { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
329         ; case sequel of
330             CaseAlts _ (Just (alts, deflt_lbl)) bndr
331               ->    -- Ho! We know the constructor so we can
332                     -- go straight to the right alternative
333                  case assocMaybe alts (dataConTagZ con) of {
334                     Just join_lbl -> build_it_then (jump_to join_lbl);
335                     Nothing
336                         -- Special case!  We're returning a constructor to the default case
337                         -- of an enclosing case.  For example:
338                         --
339                         --      case (case e of (a,b) -> C a b) of
340                         --        D x -> ...
341                         --        y   -> ...<returning here!>...
342                         --
343                         -- In this case,
344                         --      if the default is a non-bind-default (ie does not use y),
345                         --      then we should simply jump to the default join point;
346
347                         | isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
348                         | otherwise         -> build_it_then (jump_to deflt_lbl) }
349
350             _otherwise  -- The usual case
351               -> build_it_then emitReturnInstr
352         }
353   where
354     enter_it    = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
355                            CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg))) [] ]
356     jump_to lbl = stmtC (CmmJump (CmmLit lbl) [])
357     build_it_then return_code
358       = do {    -- BUILD THE OBJECT IN THE HEAP
359                 -- The first "con" says that the name bound to this
360                 -- closure is "con", which is a bit of a fudge, but it only
361                 -- affects profiling
362
363                 -- This Id is also used to get a unique for a
364                 -- temporary variable, if the closure is a CHARLIKE.
365                 -- funnily enough, this makes the unique always come
366                 -- out as '54' :-)
367              tickyReturnNewCon (length amodes)
368            ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes
369            ; amode <- idInfoToAmode idinfo
370            ; checkedAbsC (CmmAssign nodeReg amode)
371            ; performReturn return_code }
372 \end{code}
373
374
375 %************************************************************************
376 %*                                                                      *
377         Generating static stuff for algebraic data types
378 %*                                                                      *
379 %************************************************************************
380
381         [These comments are rather out of date]
382
383 \begin{tabular}{lll}
384 Info tbls &      Macro  &            Kind of constructor \\
385 \hline
386 info & @CONST_INFO_TABLE@&    Zero arity (no info -- compiler uses static closure)\\
387 info & @CHARLIKE_INFO_TABLE@& Charlike   (no info -- compiler indexes fixed array)\\
388 info & @INTLIKE_INFO_TABLE@&  Intlike; the one macro generates both info tbls\\
389 info & @SPEC_INFO_TABLE@&     SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
390 info & @GEN_INFO_TABLE@&      GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
391 \end{tabular}
392
393 Possible info tables for constructor con:
394
395 \begin{description}
396 \item[@_con_info@:]
397 Used for dynamically let(rec)-bound occurrences of
398 the constructor, and for updates.  For constructors
399 which are int-like, char-like or nullary, when GC occurs,
400 the closure tries to get rid of itself.
401
402 \item[@_static_info@:]
403 Static occurrences of the constructor
404 macro: @STATIC_INFO_TABLE@.
405 \end{description}
406
407 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
408 it's place is taken by the top level defn of the constructor.
409
410 For charlike and intlike closures there is a fixed array of static
411 closures predeclared.
412
413 \begin{code}
414 cgTyCon :: TyCon -> FCode CmmGroup  -- each constructor gets a separate CmmGroup
415 cgTyCon tycon
416   = do  { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
417
418             -- Generate a table of static closures for an enumeration type
419             -- Put the table after the data constructor decls, because the
420             -- datatype closure table (for enumeration types)
421             -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
422             -- Note that the closure pointers are tagged.
423
424             -- XXX comment says to put table after constructor decls, but
425             -- code appears to put it before --- NR 16 Aug 2007
426         ; extra <-
427            if isEnumerationTyCon tycon then do
428                 tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
429                            [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con)
430                            | con <- tyConDataCons tycon])
431                 return [tbl]
432            else
433                 return []
434
435         ; return (concat (extra ++ constrs))
436     }
437 \end{code}
438
439 Generate the entry code, info tables, and (for niladic constructor) the
440 static closure, for a constructor.
441
442 \begin{code}
443 cgDataCon :: DataCon -> Code
444 cgDataCon data_con
445   = do  {     -- Don't need any dynamic closure code for zero-arity constructors
446
447         ; let
448             -- To allow the debuggers, interpreters, etc to cope with
449             -- static data structures (ie those built at compile
450             -- time), we take care that info-table contains the
451             -- information we need.
452             (static_cl_info, _) =
453                 layOutStaticConstr data_con arg_reps
454
455             (dyn_cl_info, arg_things) =
456                 layOutDynConstr    data_con arg_reps
457
458             emit_info cl_info ticky_code
459                 = do { code_blks <- getCgStmts the_code
460                      ; emitClosureCodeAndInfoTable cl_info [] code_blks }
461                 where
462                   the_code = do { _ <- ticky_code
463                                 ; ldvEnter (CmmReg nodeReg)
464                                 ; body_code }
465
466             arg_reps :: [(CgRep, Type)]
467             arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
468
469             body_code = do {
470                         -- NB: We don't set CC when entering data (WDP 94/06)
471                              tickyReturnOldCon (length arg_things)
472                            -- The case continuation code is expecting a tagged pointer
473                            ; stmtC (CmmAssign nodeReg
474                                               (tagCons data_con (CmmReg nodeReg)))
475                            ; performReturn emitReturnInstr }
476                                 -- noStmts: Ptr to thing already in Node
477
478         ; whenC (not (isNullaryRepDataCon data_con))
479                 (emit_info dyn_cl_info tickyEnterDynCon)
480
481                 -- Dynamic-Closure first, to reduce forward references
482         ; emit_info static_cl_info tickyEnterStaticCon }
483 \end{code}