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