compiler/codeGen/StgCmmCon.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C--: code generation for constructors
   4 --
   5 -- This module provides the support code for StgCmm to deal with with
   6 -- constructors on the RHSs of let(rec)s.
   7 --
   8 -- (c) The University of Glasgow 2004-2006
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module StgCmmCon (
  13         cgTopRhsCon, buildDynCon, bindConArgs
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import StgSyn
  19 import CoreSyn  ( AltCon(..) )
  20
  21 import StgCmmMonad
  22 import StgCmmEnv
  23 import StgCmmHeap
  24 import StgCmmUtils
  25 import StgCmmClosure
  26 import StgCmmProf
  27
  28 import Cmm
  29 import CLabel
  30 import MkZipCfgCmm (CmmAGraph, mkNop)
  31 import SMRep
  32 import CostCentre
  33 import Constants
  34 import DataCon
  35 import FastString
  36 import Id
  37 import Literal
  38 import PrelInfo
  39 import Outputable
  40 import Util             ( lengthIs )
  41 import Char             ( ord )
  42
  43
  44 ---------------------------------------------------------------
  45 --      Top-level constructors
  46 ---------------------------------------------------------------
  47
  48 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
  49             -> DataCon          -- Id
  50             -> [StgArg]         -- Args
  51             -> FCode CgIdInfo
  52 cgTopRhsCon id con args
  53   = do {
  54 #if mingw32_TARGET_OS
  55         -- Windows DLLs have a problem with static cross-DLL refs.
  56         ; this_pkg <- getThisPackage
  57         ; ASSERT( not (isDllConApp this_pkg con args) ) return ()
  58 #endif
  59         ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
  60
  61         -- LAY IT OUT
  62         ; let
  63             name          = idName id
  64             lf_info       = mkConLFInfo con
  65             closure_label = mkClosureLabel name $ idCafInfo id
  66             caffy         = any stgArgHasCafRefs args
  67             (closure_info, nv_args_w_offsets)
  68                         = layOutStaticConstr con (addArgReps args)
  69
  70             get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
  71                                         ; return lit }
  72
  73         ; payload <- mapM get_lit nv_args_w_offsets
  74                 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
  75                 -- NB2: all the amodes should be Lits!
  76
  77         ; let closure_rep = mkStaticClosureFields
  78                              closure_info
  79                              dontCareCCS                -- Because it's static data
  80                              caffy                      -- Has CAF refs
  81                              payload
  82
  83                 -- BUILD THE OBJECT
  84         ; emitDataLits closure_label closure_rep
  85
  86                 -- RETURN
  87         ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
  88
  89
  90 ---------------------------------------------------------------
  91 --      Lay out and allocate non-top-level constructors
  92 ---------------------------------------------------------------
  93
  94 buildDynCon :: Id                 -- Name of the thing to which this constr will
  95                                   -- be bound
  96             -> CostCentreStack    -- Where to grab cost centre from;
  97                                   -- current CCS if currentOrSubsumedCCS
  98             -> DataCon            -- The data constructor
  99             -> [StgArg]           -- Its args
 100             -> FCode (CgIdInfo, CmmAGraph)
 101                -- Return details about how to find it and initialization code
 102
 103 {- We used to pass a boolean indicating whether all the
 104 args were of size zero, so we could use a static
 105 construtor; but I concluded that it just isn't worth it.
 106 Now I/O uses unboxed tuples there just aren't any constructors
 107 with all size-zero args.
 108
 109 The reason for having a separate argument, rather than looking at
 110 the addr modes of the args is that we may be in a "knot", and
 111 premature looking at the args will cause the compiler to black-hole!
 112 -}
 113
 114
 115 -------- buildDynCon: Nullary constructors --------------
 116 -- First we deal with the case of zero-arity constructors.  They
 117 -- will probably be unfolded, so we don't expect to see this case much,
 118 -- if at all, but it does no harm, and sets the scene for characters.
 119 --
 120 -- In the case of zero-arity constructors, or, more accurately, those
 121 -- which have exclusively size-zero (VoidRep) args, we generate no code
 122 -- at all.
 123
 124 buildDynCon binder _cc con []
 125   = return (litIdInfo binder (mkConLFInfo con)
 126                 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
 127             mkNop)
 128
 129 -------- buildDynCon: Charlike and Intlike constructors -----------
 130 {- The following three paragraphs about @Char@-like and @Int@-like
 131 closures are obsolete, but I don't understand the details well enough
 132 to properly word them, sorry. I've changed the treatment of @Char@s to
 133 be analogous to @Int@s: only a subset is preallocated, because @Char@
 134 has now 31 bits. Only literals are handled here. -- Qrczak
 135
 136 Now for @Char@-like closures.  We generate an assignment of the
 137 address of the closure to a temporary.  It would be possible simply to
 138 generate no code, and record the addressing mode in the environment,
 139 but we'd have to be careful if the argument wasn't a constant --- so
 140 for simplicity we just always asssign to a temporary.
 141
 142 Last special case: @Int@-like closures.  We only special-case the
 143 situation in which the argument is a literal in the range
 144 @mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
 145 work with any old argument, but for @Int@-like ones the argument has
 146 to be a literal.  Reason: @Char@ like closures have an argument type
 147 which is guaranteed in range.
 148
 149 Because of this, we use can safely return an addressing mode. -}
 150
 151 buildDynCon binder _cc con [arg]
 152   | maybeIntLikeCon con
 153   , StgLitArg (MachInt val) <- arg
 154   , val <= fromIntegral mAX_INTLIKE     -- Comparisons at type Integer!
 155   , val >= fromIntegral mIN_INTLIKE     -- ...ditto...
 156   = do  { let intlike_lbl   = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure")
 157               val_int = fromIntegral val :: Int
 158               offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
 159                 -- INTLIKE closures consist of a header and one word payload
 160               intlike_amode = cmmLabelOffW intlike_lbl offsetW
 161         ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
 162
 163 buildDynCon binder _cc con [arg]
 164   | maybeCharLikeCon con
 165   , StgLitArg (MachChar val) <- arg
 166   , let val_int = ord val :: Int
 167   , val_int <= mAX_CHARLIKE
 168   , val_int >= mIN_CHARLIKE
 169   = do  { let charlike_lbl   = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure")
 170               offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
 171                 -- CHARLIKE closures consist of a header and one word payload
 172               charlike_amode = cmmLabelOffW charlike_lbl offsetW
 173         ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
 174
 175 -------- buildDynCon: the general case -----------
 176 buildDynCon binder ccs con args
 177   = do  { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
 178                 -- No void args in args_w_offsets
 179         ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
 180         ; return (regIdInfo binder lf_info tmp, init) }
 181   where
 182     lf_info = mkConLFInfo con
 183
 184     use_cc      -- cost-centre to stick in the object
 185       | currentOrSubsumedCCS ccs = curCCS
 186       | otherwise                = CmmLit (mkCCostCentreStack ccs)
 187
 188     blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 189
 190
 191 ---------------------------------------------------------------
 192 --      Binding constructor arguments
 193 ---------------------------------------------------------------
 194
 195 bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg]
 196 -- bindConArgs is called from cgAlt of a case
 197 -- (bindConArgs con args) augments the environment with bindings for the
 198 -- binders args, assuming that we have just returned from a 'case' which
 199 -- found a con
 200 bindConArgs (DataAlt con) base args
 201   = ASSERT(not (isUnboxedTupleCon con))
 202     mapM bind_arg args_w_offsets
 203   where
 204     (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
 205
 206     tag = tagForCon con
 207
 208           -- The binding below forces the masking out of the tag bits
 209           -- when accessing the constructor field.
 210     bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
 211     bind_arg (arg, offset)
 212         = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
 213              ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $
 214                bindArgToReg arg }
 215
 216 bindConArgs _other_con _base args
 217   = ASSERT( null args ) return []
 218
 219
 220