StgCmmCon.hs 11 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}

3
4
5
6
7
8
9
10
11
12
13
14
-----------------------------------------------------------------------------
--
-- 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 (
15
        cgTopRhsCon, buildDynCon, bindConArgs
16
17
18
19
    ) where

#include "HsVersions.h"

20
21
import GhcPrelude

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

import StgCmmMonad
import StgCmmEnv
import StgCmmHeap
28
import StgCmmLayout
29
30
31
import StgCmmUtils
import StgCmmClosure

32
import CmmExpr
33
import CmmUtils
34
import CLabel
35
import MkGraph
36
37
import SMRep
import CostCentre
38
import Module
39
import DataCon
40
import DynFlags
41
42
import FastString
import Id
43
import RepType (countConRepArgs)
44
45
46
import Literal
import PrelInfo
import Outputable
47
import Platform
48
import Util
49
import MonadUtils (mapMaybeM)
50

51
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
52
import Data.Char
53

54

55
56

---------------------------------------------------------------
57
--      Top-level constructors
58
59
---------------------------------------------------------------

Jan Stolarek's avatar
Jan Stolarek committed
60
61
cgTopRhsCon :: DynFlags
            -> Id               -- Name of thing bound to this RHS
62
            -> DataCon          -- Id
63
            -> [NonVoid StgArg] -- Args
Jan Stolarek's avatar
Jan Stolarek committed
64
65
66
67
            -> (CgIdInfo, FCode ())
cgTopRhsCon dflags id con args =
    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
    in (id_info, gen_code)
68
69
70
71
72
73
  where
   name          = idName id
   caffy         = idCafInfo id -- any stgArgHasCafRefs args
   closure_label = mkClosureLabel name caffy

   gen_code =
Jan Stolarek's avatar
Jan Stolarek committed
74
     do { this_mod <- getModuleName
Ian Lynagh's avatar
Ian Lynagh committed
75
        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
76
              -- Windows DLLs have a problem with static cross-DLL refs.
77
              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
78
        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()
79

80
81
        -- LAY IT OUT
        ; let
Simon Marlow's avatar
Simon Marlow committed
82
            (tot_wds, --  #ptr_wds + #nonptr_wds
83
             ptr_wds, --  #ptr_wds
84
             nv_args_w_offsets) =
Simon Marlow's avatar
Simon Marlow committed
85
                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
86
87
88

            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
            mk_payload (FieldOff arg _) = do
89
90
91
92
                amode <- getArgAmode arg
                case amode of
                  CmmLit lit -> return lit
                  _          -> panic "StgCmmCon.cgTopRhsCon"
Simon Marlow's avatar
Simon Marlow committed
93
94
95
96
97
98

            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.
99
            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
100
101


102
        ; payload <- mapM mk_payload nv_args_w_offsets
103
104
                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
                -- NB2: all the amodes should be Lits!
105
                --      TODO (osa): Why?
106

107
        ; let closure_rep = mkStaticClosureFields
108
                             dflags
Simon Marlow's avatar
Simon Marlow committed
109
                             info_tbl
110
111
112
                             dontCareCCS                -- Because it's static data
                             caffy                      -- Has CAF refs
                             payload
113

114
                -- BUILD THE OBJECT
115
        ; emitDataLits closure_label closure_rep
116

117
        ; return () }
118
119
120


---------------------------------------------------------------
121
--      Lay out and allocate non-top-level constructors
122
123
---------------------------------------------------------------

124
125
buildDynCon :: Id                 -- Name of the thing to which this constr will
                                  -- be bound
126
127
            -> Bool               -- is it genuinely bound to that name, or just
                                  -- for profiling?
128
129
130
            -> CostCentreStack    -- Where to grab cost centre from;
                                  -- current CCS if currentOrSubsumedCCS
            -> DataCon            -- The data constructor
131
            -> [NonVoid StgArg]   -- Its args
132
            -> FCode (CgIdInfo, FCode CmmAGraph)
133
               -- Return details about how to find it and initialization code
134
buildDynCon binder actually_bound cc con args
135
    = do dflags <- getDynFlags
136
137
         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args

138

Ian Lynagh's avatar
Ian Lynagh committed
139
140
buildDynCon' :: DynFlags
             -> Platform
141
             -> Id -> Bool
142
143
             -> CostCentreStack
             -> DataCon
144
             -> [NonVoid StgArg]
145
             -> FCode (CgIdInfo, FCode CmmAGraph)
146
147
148

{- 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
149
constructor; but I concluded that it just isn't worth it.
150
151
152
153
154
155
156
157
158
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!
-}


159
-------- buildDynCon': Nullary constructors --------------
160
161
162
-- 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.
163
--
164
165
166
167
-- In the case of zero-arity constructors, or, more accurately, those
-- which have exclusively size-zero (VoidRep) args, we generate no code
-- at all.

168
buildDynCon' dflags _ binder _ _cc con []
169
  | isNullaryRepDataCon con
170
  = return (litIdInfo dflags binder (mkConLFInfo con)
171
                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
172
            return mkNop)
173

174
-------- buildDynCon': Charlike and Intlike constructors -----------
175
176
177
178
179
180
181
182
183
184
{- 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
185
for simplicity we just always assign to a temporary.
186
187
188
189
190
191
192
193

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.

194
Because of this, we use can safely return an addressing mode.
195

196
197
198
199
We don't support this optimisation when compiling into Windows DLLs yet
because they don't support cross package data references well.
-}

200
buildDynCon' dflags platform binder _ _cc con [arg]
201
  | maybeIntLikeCon con
202
  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
203
  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
204
205
  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
206
  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
207
              val_int = fromIntegral val :: Int
208
              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
209
                -- INTLIKE closures consist of a header and one word payload
210
              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
211
        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
212
                 , return mkNop) }
213

214
buildDynCon' dflags platform binder _ _cc con [arg]
215
  | maybeCharLikeCon con
216
  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
Sylvain Henry's avatar
Sylvain Henry committed
217
  , NonVoid (StgLitArg (LitChar val)) <- arg
218
  , let val_int = ord val :: Int
219
220
  , val_int <= mAX_CHARLIKE dflags
  , val_int >= mIN_CHARLIKE dflags
221
  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")
222
              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
223
                -- CHARLIKE closures consist of a header and one word payload
224
              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
225
        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
226
                 , return mkNop) }
227

228
-------- buildDynCon': the general case -----------
229
buildDynCon' dflags _ binder actually_bound ccs con args
230
231
232
233
234
235
236
237
238
239
240
241
  = 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)
                nonptr_wds = tot_wds - ptr_wds
                info_tbl = mkDataConInfoTable dflags con False
                                ptr_wds nonptr_wds
242
243
244
245
          ; let ticky_name | actually_bound = Just binder
                           | otherwise = Nothing

          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
246
                                          use_cc blame_cc args_w_offsets
247
          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
248
249
    where
      use_cc      -- cost-centre to stick in the object
250
        | isCurrentCCS ccs = cccsExpr
251
        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
252

253
      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
254
255
256


---------------------------------------------------------------
257
--      Binding constructor arguments
258
259
---------------------------------------------------------------

260
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
261
262
263
264
265
266
-- 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))
267
268
    do dflags <- getDynFlags
       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
269
270
271
272
           tag = tagForCon dflags con

           -- The binding below forces the masking out of the tag bits
           -- when accessing the constructor field.
273
           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
274
275
276
277
278
279
280
281
282
283
284
           bind_arg (arg@(NonVoid b), offset)
             | isDeadBinder b =
                 -- Do not load unused fields from objects to local variables.
                 -- (CmmSink can optimize this, but it's cheap and common enough
                 -- to handle here)
                 return Nothing
             | otherwise      = do
                 emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
                 Just <$> bindArgToReg arg

       mapMaybeM bind_arg args_w_offsets
285
286
287

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