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