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