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