ghc/compiler/basicTypes/DataCon.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[DataCon]{@DataCon@: Data Constructors}
   5
   6 \begin{code}
   7 module DataCon (
   8         DataCon,
   9         ConTag, fIRST_TAG,
  10         mkDataCon,
  11         dataConType, dataConSig, dataConName, dataConTag, dataConTyCon,
  12         dataConArgTys, dataConOrigArgTys,
  13         dataConRawArgTys, dataConAllRawArgTys,
  14         dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
  15         dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness,
  16         isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
  17         isExistentialDataCon, splitProductType_maybe,
  18
  19         StrictnessMark(..),     -- Representation visible to MkId only
  20         markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
  26
  27 import CmdLineOpts      ( opt_DictsStrict )
  28 import TysPrim
  29 import Type             ( Type, ThetaType, TauType, ClassContext,
  30                           mkSigmaTy, mkFunTys, mkTyConApp,
  31                           mkTyVarTys, mkDictTy,
  32                           splitAlgTyConApp_maybe, classesToPreds
  33                         )
  34 import PprType
  35 import TyCon            ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
  36                           isTupleTyCon, isUnboxedTupleTyCon )
  37 import Class            ( classTyCon )
  38 import Name             ( Name, NamedThing(..), nameUnique, isLocallyDefined )
  39 import Var              ( TyVar, Id )
  40 import FieldLabel       ( FieldLabel )
  41 import BasicTypes       ( Arity )
  42 import Demand           ( Demand, wwStrict, wwLazy )
  43 import Outputable
  44 import Unique           ( Unique, Uniquable(..) )
  45 import CmdLineOpts      ( opt_UnboxStrictFields )
  46 import UniqSet
  47 import Maybes           ( maybeToBool )
  48 import Maybe
  49 import Util             ( assoc )
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Data constructors}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 data DataCon
  61   = MkData {                    -- Used for data constructors only;
  62                                 -- there *is* no constructor for a newtype
  63         dcName   :: Name,
  64         dcUnique :: Unique,             -- Cached from Name
  65         dcTag    :: ConTag,
  66
  67         -- Running example:
  68         --
  69         --      data Eq a => T a = forall b. Ord b => MkT a [b]
  70
  71         dcType   :: Type,       -- Type of the constructor
  72                                 --      forall ab . Ord b => a -> [b] -> MkT a
  73                                 -- (this is *not* of the constructor Id:
  74                                 --  see notes after this data type declaration)
  75
  76         -- The next six fields express the type of the constructor, in pieces
  77         -- e.g.
  78         --
  79         --      dcTyVars   = [a]
  80         --      dcTheta    = [Eq a]
  81         --      dcExTyVars = [b]
  82         --      dcExTheta  = [Ord b]
  83         --      dcOrigArgTys   = [a,List b]
  84         --      dcTyCon    = T
  85
  86         dcTyVars :: [TyVar],            -- Type vars and context for the data type decl
  87         dcTheta  ::  ClassContext,
  88
  89         dcExTyVars :: [TyVar],          -- Ditto for the context of the constructor,
  90         dcExTheta  :: ClassContext,     -- the existentially quantified stuff
  91
  92         dcOrigArgTys :: [Type],         -- Original argument types
  93                                         -- (before unboxing and flattening of
  94                                         --  strict fields)
  95         dcRepArgTys :: [Type],          -- Constructor Argument types
  96         dcTyCon  :: TyCon,              -- Result tycon
  97
  98         -- Now the strictness annotations and field labels of the constructor
  99         dcUserStricts :: [StrictnessMark],
 100                 -- Strictness annotations, as placed on the data type defn,
 101                 -- in the same order as the argument types;
 102                 -- length = dataConNumFields dataCon
 103
 104         dcRealStricts :: [StrictnessMark],
 105                 -- Strictness annotations as deduced by the compiler.  May
 106                 -- include some MarkedUnboxed fields that are MarkedStrict
 107                 -- in dcUserStricts.
 108                 -- length = dataConNumFields dataCon
 109
 110         dcFields  :: [FieldLabel],
 111                 -- Field labels for this constructor, in the
 112                 -- same order as the argument types;
 113                 -- length = 0 (if not a record) or dataConSourceArity.
 114
 115         -- Finally, the curried function that corresponds to the constructor
 116         --      mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a
 117         --      mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs]
 118         -- This unfolding is built in MkId.mkDataConId
 119
 120         dcId :: Id                      -- The corresponding Id
 121   }
 122
 123 type ConTag = Int
 124
 125 fIRST_TAG :: ConTag
 126 fIRST_TAG =  1  -- Tags allocated from here for real constructors
 127 \end{code}
 128
 129 The dcType field contains the type of the representation of a contructor
 130 This may differ from the type of the contructor *Id* (built
 131 by MkId.mkDataConId) for two reasons:
 132         a) the constructor Id may be overloaded, but the dictionary isn't stored
 133            e.g.    data Eq a => T a = MkT a a
 134
 135         b) the constructor may store an unboxed version of a strict field.
 136
 137 Here's an example illustrating both:
 138         data Ord a => T a = MkT Int! a
 139 Here
 140         T :: Ord a => Int -> a -> T a
 141 but the rep type is
 142         Trep :: Int# -> a -> T a
 143 Actually, the unboxed part isn't implemented yet!
 144
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection{Strictness indication}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 \begin{code}
 153 data StrictnessMark = MarkedStrict
 154                     | MarkedUnboxed DataCon [Type]
 155                     | NotMarkedStrict
 156
 157 markedStrict    = MarkedStrict
 158 notMarkedStrict = NotMarkedStrict
 159 markedUnboxed   = MarkedUnboxed (panic "markedUnboxed1") (panic "markedUnboxed2")
 160
 161 maybeMarkedUnboxed (MarkedUnboxed dc tys) = Just (dc,tys)
 162 maybeMarkedUnboxed other                  = Nothing
 163 \end{code}
 164
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection{Instances}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 \begin{code}
 173 instance Eq DataCon where
 174     a == b = getUnique a == getUnique b
 175     a /= b = getUnique a /= getUnique b
 176
 177 instance Ord DataCon where
 178     a <= b = getUnique a <= getUnique b
 179     a <  b = getUnique a <  getUnique b
 180     a >= b = getUnique a >= getUnique b
 181     a >  b = getUnique a > getUnique b
 182     compare a b = getUnique a `compare` getUnique b
 183
 184 instance Uniquable DataCon where
 185     getUnique = dcUnique
 186
 187 instance NamedThing DataCon where
 188     getName = dcName
 189
 190 instance Outputable DataCon where
 191     ppr con = ppr (dataConName con)
 192
 193 instance Show DataCon where
 194     showsPrec p con = showsPrecSDoc p (ppr con)
 195 \end{code}
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200 \subsection{Consruction}
 201 %*                                                                      *
 202 %************************************************************************
 203
 204 \begin{code}
 205 mkDataCon :: Name
 206           -> [StrictnessMark] -> [FieldLabel]
 207           -> [TyVar] -> ClassContext
 208           -> [TyVar] -> ClassContext
 209           -> [TauType] -> TyCon
 210           -> Id
 211           -> DataCon
 212   -- Can get the tag from the TyCon
 213
 214 mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon id
 215   = ASSERT(length arg_stricts == length orig_arg_tys)
 216         -- The 'stricts' passed to mkDataCon are simply those for the
 217         -- source-language arguments.  We add extra ones for the
 218         -- dictionary arguments right here.
 219     con
 220   where
 221     con = MkData {dcName = name, dcUnique = nameUnique name,
 222                   dcTyVars = tyvars, dcTheta = theta,
 223                   dcOrigArgTys = orig_arg_tys,
 224                   dcRepArgTys = rep_arg_tys,
 225                   dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
 226                   dcRealStricts = all_stricts, dcUserStricts = user_stricts,
 227                   dcFields = fields, dcTag = tag, dcTyCon = tycon, dcType = ty,
 228                   dcId = id}
 229
 230     (real_arg_stricts, strict_arg_tyss)
 231         = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
 232     rep_arg_tys = concat strict_arg_tyss
 233
 234     ex_dict_stricts = map mk_dict_strict_mark ex_theta
 235         -- Add a strictness flag for the existential dictionary arguments
 236     all_stricts     = ex_dict_stricts ++ real_arg_stricts
 237     user_stricts    = ex_dict_stricts ++ arg_stricts
 238
 239     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
 240     ty  = mkSigmaTy (tyvars ++ ex_tyvars)
 241                     (classesToPreds ex_theta)
 242                     (mkFunTys rep_arg_tys
 243                         (mkTyConApp tycon (mkTyVarTys tyvars)))
 244
 245 mk_dict_strict_mark (clas,tys)
 246   | opt_DictsStrict &&
 247         -- Don't mark newtype things as strict!
 248     isDataTyCon (classTyCon clas) = MarkedStrict
 249   | otherwise                     = NotMarkedStrict
 250 \end{code}
 251
 252 \begin{code}
 253 dataConName :: DataCon -> Name
 254 dataConName = dcName
 255
 256 dataConTag :: DataCon -> ConTag
 257 dataConTag  = dcTag
 258
 259 dataConTyCon :: DataCon -> TyCon
 260 dataConTyCon = dcTyCon
 261
 262 dataConType :: DataCon -> Type
 263 dataConType = dcType
 264
 265 dataConId :: DataCon -> Id
 266 dataConId = dcId
 267
 268
 269 dataConFieldLabels :: DataCon -> [FieldLabel]
 270 dataConFieldLabels = dcFields
 271
 272 dataConStrictMarks :: DataCon -> [StrictnessMark]
 273 dataConStrictMarks = dcRealStricts
 274
 275 dataConSourceArity :: DataCon -> Arity
 276         -- Source-level arity of the data constructor
 277 dataConSourceArity dc = length (dcOrigArgTys dc)
 278
 279 dataConRepStrictness :: DataCon -> [Demand]
 280         -- Give the demands on the arguments of a
 281         -- Core constructor application (Con dc args)
 282 dataConRepStrictness dc
 283   = go (dcRealStricts dc)
 284   where
 285     go []                         = []
 286     go (MarkedStrict        : ss) = wwStrict : go ss
 287     go (NotMarkedStrict     : ss) = wwLazy   : go ss
 288     go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
 289
 290 dataConSig :: DataCon -> ([TyVar], ClassContext,
 291                           [TyVar], ClassContext,
 292                           [TauType], TyCon)
 293
 294 dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
 295                      dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
 296                      dcOrigArgTys = arg_tys, dcTyCon = tycon})
 297   = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
 298
 299 dataConArgTys :: DataCon
 300               -> [Type]         -- Instantiated at these types
 301                                 -- NB: these INCLUDE the existentially quantified arg types
 302               -> [Type]         -- Needs arguments of these types
 303                                 -- NB: these INCLUDE the existentially quantified dict args
 304                                 --     but EXCLUDE the data-decl context which is discarded
 305
 306 dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
 307                        dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
 308  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys))
 309        ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
 310 \end{code}
 311
 312 These two functions get the real argument types of the constructor,
 313 without substituting for any type variables.  dataConAllRawArgTys is
 314 like dataConRawArgTys except that the existential dictionary arguments
 315 are included.  dataConOrigArgTys is the same, but returns the types
 316 written by the programmer.
 317
 318 \begin{code}
 319 dataConOrigArgTys :: DataCon -> [Type]
 320 dataConOrigArgTys dc = dcOrigArgTys dc
 321
 322 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
 323 dataConRawArgTys dc = dcRepArgTys dc
 324
 325 dataConAllRawArgTys :: DataCon -> [TauType]
 326 dataConAllRawArgTys con =
 327   [mkDictTy cls tys | (cls,tys) <- dcExTheta con] ++ dcRepArgTys con
 328 \end{code}
 329
 330 dataConNumFields gives the number of actual fields in the
 331 {\em representation} of the data constructor.  This may be more than appear
 332 in the source code; the extra ones are the existentially quantified
 333 dictionaries
 334
 335 \begin{code}
 336 -- Number of type-instantiation arguments
 337 -- All the remaining arguments of the DataCon are (notionally)
 338 -- stored in the DataCon, and are matched in a case expression
 339 dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
 340
 341 dataConNumFields (MkData {dcExTheta = theta, dcRepArgTys = arg_tys})
 342   = length theta + length arg_tys
 343
 344 isNullaryDataCon con
 345   = dataConNumFields con == 0 -- function of convenience
 346
 347 isTupleCon :: DataCon -> Bool
 348 isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
 349
 350 isUnboxedTupleCon :: DataCon -> Bool
 351 isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
 352
 353 isExistentialDataCon :: DataCon -> Bool
 354 isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
 355 \end{code}
 356
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection{Splitting products}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 \begin{code}
 365 splitProductType_maybe
 366         :: Type                         -- A product type, perhaps
 367         -> Maybe (TyCon,                -- The type constructor
 368                   [Type],               -- Type args of the tycon
 369                   DataCon,              -- The data constructor
 370                   [Type])               -- Its *representation* arg types
 371
 372         -- Returns (Just ...) for any
 373         --      single-constructor
 374         --      non-recursive type
 375         --      not existentially quantified
 376         -- type whether a data type or a new type
 377         --
 378         -- Rejecing existentials is conservative.  Maybe some things
 379         -- could be made to work with them, but I'm not going to sweat
 380         -- it through till someone finds it's important.
 381
 382 splitProductType_maybe ty
 383   = case splitAlgTyConApp_maybe ty of
 384         Just (tycon,ty_args,[data_con])
 385            | isProductTyCon tycon               -- Checks for non-recursive, non-existential
 386            -> Just (tycon, ty_args, data_con, data_con_arg_tys)
 387            where
 388               data_con_arg_tys = map (substTy (mkTyVarSubst (dcTyVars data_con) ty_args))
 389                                      (dcRepArgTys data_con)
 390         other -> Nothing
 391
 392
 393 -- We attempt to unbox/unpack a strict field when either:
 394 --   (i)  The tycon is imported, and the field is marked '! !', or
 395 --   (ii) The tycon is defined in this module, the field is marked '!',
 396 --        and the -funbox-strict-fields flag is on.
 397 --
 398 -- This ensures that if we compile some modules with -funbox-strict-fields and
 399 -- some without, the compiler doesn't get confused about the constructor
 400 -- representations.
 401
 402 unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
 403
 404 unbox_strict_arg_ty tycon strict_mark ty
 405   | case strict_mark of
 406         NotMarkedStrict   -> False
 407         MarkedUnboxed _ _ -> True
 408         MarkedStrict      -> opt_UnboxStrictFields &&
 409                              isLocallyDefined tycon &&
 410                              maybeToBool maybe_product &&
 411                              isDataTyCon arg_tycon
 412         -- We can't look through newtypes in arguments (yet)
 413   = (MarkedUnboxed con arg_tys, arg_tys)
 414
 415   | otherwise
 416   = (strict_mark, [ty])
 417
 418   where
 419     maybe_product = splitProductType_maybe ty
 420     Just (arg_tycon, _, con, arg_tys) = maybe_product
 421 \end{code}
 422
 423