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