StgCmmCon.hs 10.3 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12
-----------------------------------------------------------------------------
--
-- Stg to C--: code generation for constructors
--
-- This module provides the support code for StgCmm to deal with with
-- constructors on the RHSs of let(rec)s.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmmCon (
13
        cgTopRhsCon, buildDynCon, bindConArgs
14 15 16 17 18
    ) where

#include "HsVersions.h"

import StgSyn
19
import CoreSyn  ( AltCon(..) )
20 21 22 23 24 25 26 27

import StgCmmMonad
import StgCmmEnv
import StgCmmHeap
import StgCmmUtils
import StgCmmClosure
import StgCmmProf

28
import CmmExpr
29
import CLabel
30
import MkGraph
31 32
import SMRep
import CostCentre
33
import Module
34
import DataCon
35
import DynFlags
36 37 38 39 40
import FastString
import Id
import Literal
import PrelInfo
import Outputable
41
import Platform
42
import Util
43

44
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
45
import Data.Char
46

47

48 49

---------------------------------------------------------------
50
--      Top-level constructors
51 52
---------------------------------------------------------------

53 54 55
cgTopRhsCon :: Id               -- Name of thing bound to this RHS
            -> DataCon          -- Id
            -> [StgArg]         -- Args
56
            -> FCode (CgIdInfo, FCode ())
57
cgTopRhsCon id con args
58 59 60
  = do dflags <- getDynFlags
       let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
       return ( id_info, gen_code )
61 62 63 64 65 66 67
  where
   name          = idName id
   caffy         = idCafInfo id -- any stgArgHasCafRefs args
   closure_label = mkClosureLabel name caffy

   gen_code =
     do { dflags <- getDynFlags
68
        ; this_mod <- getModuleName
Ian Lynagh's avatar
Ian Lynagh committed
69
        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
70
              -- Windows DLLs have a problem with static cross-DLL refs.
71
              ASSERT( not (isDllConApp dflags this_mod con args) ) return ()
72
        ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
73

74 75
        -- LAY IT OUT
        ; let
Simon Marlow's avatar
Simon Marlow committed
76
            (tot_wds, --  #ptr_wds + #nonptr_wds
77
             ptr_wds, --  #ptr_wds
78
             nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)
Simon Marlow's avatar
Simon Marlow committed
79 80 81 82 83 84

            nonptr_wds = tot_wds - ptr_wds

             -- we're not really going to emit an info table, so having
             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
             -- needs to poke around inside it.
85
            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
86

87 88
            get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
                                        ; return lit }
89

90 91 92
        ; payload <- mapM get_lit nv_args_w_offsets
                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
                -- NB2: all the amodes should be Lits!
93

94
        ; let closure_rep = mkStaticClosureFields
95
                             dflags
Simon Marlow's avatar
Simon Marlow committed
96
                             info_tbl
97 98 99
                             dontCareCCS                -- Because it's static data
                             caffy                      -- Has CAF refs
                             payload
100

101 102
                -- BUILD THE OBJECT
        ; emitDataLits closure_label closure_rep
103

104
        ; return () }
105 106 107


---------------------------------------------------------------
108
--      Lay out and allocate non-top-level constructors
109 110
---------------------------------------------------------------

111 112
buildDynCon :: Id                 -- Name of the thing to which this constr will
                                  -- be bound
113
            -> Bool   -- is it genuinely bound to that name, or just for profiling?
114 115 116 117
            -> CostCentreStack    -- Where to grab cost centre from;
                                  -- current CCS if currentOrSubsumedCCS
            -> DataCon            -- The data constructor
            -> [StgArg]           -- Its args
118
            -> FCode (CgIdInfo, FCode CmmAGraph)
119
               -- Return details about how to find it and initialization code
120
buildDynCon binder actually_bound cc con args
121
    = do dflags <- getDynFlags
122 123
         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args

124

Ian Lynagh's avatar
Ian Lynagh committed
125 126
buildDynCon' :: DynFlags
             -> Platform
127
             -> Id -> Bool
128 129 130
             -> CostCentreStack
             -> DataCon
             -> [StgArg]
131
             -> FCode (CgIdInfo, FCode CmmAGraph)
132 133 134

{- We used to pass a boolean indicating whether all the
args were of size zero, so we could use a static
Gabor Greif's avatar
Gabor Greif committed
135
constructor; but I concluded that it just isn't worth it.
136 137 138 139 140 141 142 143 144
Now I/O uses unboxed tuples there just aren't any constructors
with all size-zero args.

The reason for having a separate argument, rather than looking at
the addr modes of the args is that we may be in a "knot", and
premature looking at the args will cause the compiler to black-hole!
-}


145
-------- buildDynCon': Nullary constructors --------------
146 147 148
-- First we deal with the case of zero-arity constructors.  They
-- will probably be unfolded, so we don't expect to see this case much,
-- if at all, but it does no harm, and sets the scene for characters.
149
--
150 151 152 153
-- In the case of zero-arity constructors, or, more accurately, those
-- which have exclusively size-zero (VoidRep) args, we generate no code
-- at all.

154
buildDynCon' dflags _ binder _ _cc con []
155
  = return (litIdInfo dflags binder (mkConLFInfo con)
156
                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
157
            return mkNop)
158

159
-------- buildDynCon': Charlike and Intlike constructors -----------
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
{- The following three paragraphs about @Char@-like and @Int@-like
closures are obsolete, but I don't understand the details well enough
to properly word them, sorry. I've changed the treatment of @Char@s to
be analogous to @Int@s: only a subset is preallocated, because @Char@
has now 31 bits. Only literals are handled here. -- Qrczak

Now for @Char@-like closures.  We generate an assignment of the
address of the closure to a temporary.  It would be possible simply to
generate no code, and record the addressing mode in the environment,
but we'd have to be careful if the argument wasn't a constant --- so
for simplicity we just always asssign to a temporary.

Last special case: @Int@-like closures.  We only special-case the
situation in which the argument is a literal in the range
@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
work with any old argument, but for @Int@-like ones the argument has
to be a literal.  Reason: @Char@ like closures have an argument type
which is guaranteed in range.

179
Because of this, we use can safely return an addressing mode.
180

181 182 183 184
We don't support this optimisation when compiling into Windows DLLs yet
because they don't support cross package data references well.
-}

185
buildDynCon' dflags platform binder _ _cc con [arg]
186
  | maybeIntLikeCon con
ian@well-typed.com's avatar
ian@well-typed.com committed
187
  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
188
  , StgLitArg (MachInt val) <- arg
189 190
  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
191
  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
192
              val_int = fromIntegral val :: Int
193
              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
194
                -- INTLIKE closures consist of a header and one word payload
195
              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
196
        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
197
                 , return mkNop) }
198

199
buildDynCon' dflags platform binder _ _cc con [arg]
200
  | maybeCharLikeCon con
ian@well-typed.com's avatar
ian@well-typed.com committed
201
  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
202 203
  , StgLitArg (MachChar val) <- arg
  , let val_int = ord val :: Int
204 205
  , val_int <= mAX_CHARLIKE dflags
  , val_int >= mIN_CHARLIKE dflags
206
  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
207
              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
208
                -- CHARLIKE closures consist of a header and one word payload
209
              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
210
        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
211
                 , return mkNop) }
212

213
-------- buildDynCon': the general case -----------
214
buildDynCon' dflags _ binder actually_bound ccs con args
215 216 217 218 219 220 221 222 223 224 225 226 227
  = do  { (id_info, reg) <- rhsIdInfo binder lf_info
        ; return (id_info, gen_code reg)
        }
 where
  lf_info = mkConLFInfo con

  gen_code reg
    = do  { let (tot_wds, ptr_wds, args_w_offsets)
                  = mkVirtConstrOffsets dflags (addArgReps args)
                  -- No void args in args_w_offsets
                nonptr_wds = tot_wds - ptr_wds
                info_tbl = mkDataConInfoTable dflags con False
                                ptr_wds nonptr_wds
228 229 230 231
          ; let ticky_name | actually_bound = Just binder
                           | otherwise = Nothing

          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
232
                                          use_cc blame_cc args_w_offsets
233
          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
234 235 236 237 238 239
    where
      use_cc      -- cost-centre to stick in the object
        | isCurrentCCS ccs = curCCS
        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
  
      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
240 241 242


---------------------------------------------------------------
243
--      Binding constructor arguments
244 245 246 247 248 249 250 251 252
---------------------------------------------------------------

bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg]
-- bindConArgs is called from cgAlt of a case
-- (bindConArgs con args) augments the environment with bindings for the
-- binders args, assuming that we have just returned from a 'case' which
-- found a con
bindConArgs (DataAlt con) base args
  = ASSERT(not (isUnboxedTupleCon con))
253 254
    do dflags <- getDynFlags
       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
255 256 257 258 259 260 261 262
           tag = tagForCon dflags con

           -- The binding below forces the masking out of the tag bits
           -- when accessing the constructor field.
           bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
           bind_arg (arg, offset)
               = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
                    bindArgToReg arg
263
       mapM bind_arg args_w_offsets
264 265 266 267

bindConArgs _other_con _base args
  = ASSERT( null args ) return []