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