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