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,
  12         dataConArgTys, dataConTyCon,
  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,
  30                           mkSigmaTy, mkFunTys, mkTyConApp,
  31                           mkTyVarTys, mkDictTy,
  32                           splitAlgTyConApp_maybe
  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  ::  ThetaType,
  88
  89         dcExTyVars :: [TyVar],          -- Ditto for the context of the constructor,
  90         dcExTheta  :: ThetaType,        -- 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] -> ThetaType
 208           -> [TyVar] -> ThetaType
 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                     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], ThetaType,
 291                           [TyVar], ThetaType,
 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.
 316
 317 \begin{code}
 318 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
 319 dataConRawArgTys = dcRepArgTys
 320
 321 dataConAllRawArgTys :: DataCon -> [TauType]
 322 dataConAllRawArgTys con =
 323   [mkDictTy cls tys | (cls,tys) <- dcExTheta con] ++ dcRepArgTys con
 324 \end{code}
 325
 326 dataConNumFields gives the number of actual fields in the
 327 {\em representation} of the data constructor.  This may be more than appear
 328 in the source code; the extra ones are the existentially quantified
 329 dictionaries
 330
 331 \begin{code}
 332 -- Number of type-instantiation arguments
 333 -- All the remaining arguments of the DataCon are (notionally)
 334 -- stored in the DataCon, and are matched in a case expression
 335 dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
 336
 337 dataConNumFields (MkData {dcExTheta = theta, dcRepArgTys = arg_tys})
 338   = length theta + length arg_tys
 339
 340 isNullaryDataCon con
 341   = dataConNumFields con == 0 -- function of convenience
 342
 343 isTupleCon :: DataCon -> Bool
 344 isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
 345
 346 isUnboxedTupleCon :: DataCon -> Bool
 347 isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
 348
 349 isExistentialDataCon :: DataCon -> Bool
 350 isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Splitting products}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 \begin{code}
 361 splitProductType_maybe
 362         :: Type                         -- A product type, perhaps
 363         -> Maybe (TyCon,                -- The type constructor
 364                   [Type],               -- Type args of the tycon
 365                   DataCon,              -- The data constructor
 366                   [Type])               -- Its *representation* arg types
 367
 368         -- Returns (Just ...) for any
 369         --      single-constructor
 370         --      non-recursive type
 371         --      not existentially quantified
 372         -- type whether a data type or a new type
 373         --
 374         -- Rejecing existentials is conservative.  Maybe some things
 375         -- could be made to work with them, but I'm not going to sweat
 376         -- it through till someone finds it's important.
 377
 378 splitProductType_maybe ty
 379   = case splitAlgTyConApp_maybe ty of
 380         Just (tycon,ty_args,[data_con])
 381            | isProductTyCon tycon               -- Checks for non-recursive, non-existential
 382            -> Just (tycon, ty_args, data_con, data_con_arg_tys)
 383            where
 384               data_con_arg_tys = map (substTy (mkTyVarSubst (dcTyVars data_con) ty_args))
 385                                      (dcRepArgTys data_con)
 386         other -> Nothing
 387
 388
 389 -- We attempt to unbox/unpack a strict field when either:
 390 --   (i)  The tycon is imported, and the field is marked '! !', or
 391 --   (ii) The tycon is defined in this module, the field is marked '!',
 392 --        and the -funbox-strict-fields flag is on.
 393 --
 394 -- This ensures that if we compile some modules with -funbox-strict-fields and
 395 -- some without, the compiler doesn't get confused about the constructor
 396 -- representations.
 397
 398 unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
 399
 400 unbox_strict_arg_ty tycon strict_mark ty
 401   | case strict_mark of
 402         NotMarkedStrict   -> False
 403         MarkedUnboxed _ _ -> True
 404         MarkedStrict      -> opt_UnboxStrictFields &&
 405                              isLocallyDefined tycon &&
 406                              maybeToBool maybe_product &&
 407                              isDataTyCon arg_tycon
 408         -- We can't look through newtypes in arguments (yet)
 409   = (MarkedUnboxed con arg_tys, arg_tys)
 410
 411   | otherwise
 412   = (strict_mark, [ty])
 413
 414   where
 415     maybe_product = splitProductType_maybe ty
 416     Just (arg_tycon, _, con, arg_tys) = maybe_product
 417 \end{code}
 418
 419