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