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