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         dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
  12         dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
  13         dataConRepArgTys, dataConTheta,
  14         dataConFieldLabels, dataConStrictMarks,
  15         dataConSourceArity, dataConRepArity,
  16         dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
  17         isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
  18         isExistentialDataCon, classDataCon,
  19
  20         splitProductType_maybe, splitProductType,
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import {-# SOURCE #-} Subst( substTyWith )
  26 import {-# SOURCE #-} PprType( pprType )
  27
  28 import CmdLineOpts      ( opt_DictsStrict )
  29 import Type             ( Type, TauType, ThetaType,
  30                           mkForAllTys, mkFunTys, mkTyConApp,
  31                           mkTyVarTys, splitTyConApp_maybe, repType,
  32                           mkPredTys, isStrictType
  33                         )
  34 import TyCon            ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
  35                           isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
  36 import Class            ( Class, classTyCon )
  37 import Name             ( Name, NamedThing(..), nameUnique )
  38 import Var              ( TyVar, Id )
  39 import FieldLabel       ( FieldLabel )
  40 import BasicTypes       ( Arity, StrictnessMark(..) )
  41 import NewDemand        ( Demand, lazyDmd, seqDmd )
  42 import Outputable
  43 import Unique           ( Unique, Uniquable(..) )
  44 import CmdLineOpts      ( opt_UnboxStrictFields )
  45 import Maybe
  46 import ListSetOps       ( assoc )
  47 import Util             ( zipEqual, zipWithEqual )
  48 \end{code}
  49
  50
  51 Stuff about data constructors
  52 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  53 Every constructor, C, comes with a
  54
  55   *wrapper*, called C, whose type is exactly what it looks like
  56         in the source program. It is an ordinary function,
  57         and it gets a top-level binding like any other function
  58
  59   *worker*, called $wC, which is the actual data constructor.
  60         Its type may be different to C, because:
  61                 - useless dict args are dropped
  62                 - strict args may be flattened
  63         It does not have a binding.
  64
  65   The worker is very like a primop, in that it has no binding,
  66
  67
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{Data constructors}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 data DataCon
  77   = MkData {                    -- Used for data constructors only;
  78                                 -- there *is* no constructor for a newtype
  79         dcName   :: Name,
  80         dcUnique :: Unique,             -- Cached from Name
  81         dcTag    :: ConTag,
  82
  83         -- Running example:
  84         --
  85         --      data Eq a => T a = forall b. Ord b => MkT a [b]
  86
  87         dcRepType   :: Type,    -- Type of the constructor
  88                                 --      forall ab . Ord b => a -> [b] -> MkT a
  89                                 -- (this is *not* of the constructor Id:
  90                                 --  see notes after this data type declaration)
  91
  92         -- The next six fields express the type of the constructor, in pieces
  93         -- e.g.
  94         --
  95         --      dcTyVars   = [a]
  96         --      dcTheta    = [Eq a]
  97         --      dcExTyVars = [b]
  98         --      dcExTheta  = [Ord b]
  99         --      dcOrigArgTys   = [a,List b]
 100         --      dcTyCon    = T
 101
 102         dcTyVars :: [TyVar],            -- Type vars and context for the data type decl
 103                                         -- These are ALWAYS THE SAME AS THE TYVARS
 104                                         -- FOR THE PARENT TyCon.  We occasionally rely on
 105                                         -- this just to avoid redundant instantiation
 106         dcTheta  ::  ThetaType,
 107
 108         dcExTyVars :: [TyVar],          -- Ditto for the context of the constructor,
 109         dcExTheta  :: ThetaType,        -- the existentially quantified stuff
 110
 111         dcOrigArgTys :: [Type],         -- Original argument types
 112                                         -- (before unboxing and flattening of
 113                                         --  strict fields)
 114
 115         dcRepArgTys :: [Type],          -- Final, representation argument types, after unboxing and flattening,
 116                                         -- and including existential dictionaries
 117
 118         dcRepStrictness :: [Demand],    -- One for each representation argument
 119
 120         dcTyCon  :: TyCon,              -- Result tycon
 121
 122         -- Now the strictness annotations and field labels of the constructor
 123         dcStrictMarks :: [StrictnessMark],
 124                 -- Strictness annotations as deduced by the compiler.
 125                 -- Has no MarkedUserStrict; they have been changed to MarkedStrict
 126                 -- or MarkedUnboxed by the compiler.
 127                 -- *Includes the existential dictionaries*
 128                 -- length = length dcExTheta + dataConSourceArity dataCon
 129
 130         dcFields  :: [FieldLabel],
 131                 -- Field labels for this constructor, in the
 132                 -- same order as the argument types;
 133                 -- length = 0 (if not a record) or dataConSourceArity.
 134
 135         -- Finally, the curried worker function that corresponds to the constructor
 136         -- It doesn't have an unfolding; the code generator saturates these Ids
 137         -- and allocates a real constructor when it finds one.
 138         --
 139         -- An entirely separate wrapper function is built in TcTyDecls
 140
 141         dcId :: Id,             -- The corresponding worker Id
 142                                 -- Takes dcRepArgTys as its arguments
 143
 144         dcWrapId :: Id          -- The wrapper Id
 145   }
 146
 147 type ConTag = Int
 148
 149 fIRST_TAG :: ConTag
 150 fIRST_TAG =  1  -- Tags allocated from here for real constructors
 151 \end{code}
 152
 153 The dcRepType field contains the type of the representation of a contructor
 154 This may differ from the type of the contructor *Id* (built
 155 by MkId.mkDataConId) for two reasons:
 156         a) the constructor Id may be overloaded, but the dictionary isn't stored
 157            e.g.    data Eq a => T a = MkT a a
 158
 159         b) the constructor may store an unboxed version of a strict field.
 160
 161 Here's an example illustrating both:
 162         data Ord a => T a = MkT Int! a
 163 Here
 164         T :: Ord a => Int -> a -> T a
 165 but the rep type is
 166         Trep :: Int# -> a -> T a
 167 Actually, the unboxed part isn't implemented yet!
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Instances}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 instance Eq DataCon where
 178     a == b = getUnique a == getUnique b
 179     a /= b = getUnique a /= getUnique b
 180
 181 instance Ord DataCon where
 182     a <= b = getUnique a <= getUnique b
 183     a <  b = getUnique a <  getUnique b
 184     a >= b = getUnique a >= getUnique b
 185     a >  b = getUnique a > getUnique b
 186     compare a b = getUnique a `compare` getUnique b
 187
 188 instance Uniquable DataCon where
 189     getUnique = dcUnique
 190
 191 instance NamedThing DataCon where
 192     getName = dcName
 193
 194 instance Outputable DataCon where
 195     ppr con = ppr (dataConName con)
 196
 197 instance Show DataCon where
 198     showsPrec p con = showsPrecSDoc p (ppr con)
 199 \end{code}
 200
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection{Consruction}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 \begin{code}
 209 mkDataCon :: Name
 210           -> [StrictnessMark] -> [FieldLabel]
 211           -> [TyVar] -> ThetaType
 212           -> [TyVar] -> ThetaType
 213           -> [TauType] -> TyCon
 214           -> Id -> Id
 215           -> DataCon
 216   -- Can get the tag from the TyCon
 217
 218 mkDataCon name arg_stricts fields
 219           tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
 220           work_id wrap_id
 221   = ASSERT(length arg_stricts == length orig_arg_tys)
 222         -- The 'stricts' passed to mkDataCon are simply those for the
 223         -- source-language arguments.  We add extra ones for the
 224         -- dictionary arguments right here.
 225     con
 226   where
 227     con = MkData {dcName = name, dcUnique = nameUnique name,
 228                   dcTyVars = tyvars, dcTheta = theta,
 229                   dcOrigArgTys = orig_arg_tys,
 230                   dcRepArgTys = rep_arg_tys,
 231                   dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
 232                   dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands,
 233                   dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
 234                   dcId = work_id, dcWrapId = wrap_id}
 235
 236         -- Strictness marks for source-args
 237         --      *after unboxing choices*,
 238         -- but  *including existential dictionaries*
 239     ex_dict_tys  = mkPredTys ex_theta
 240     real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
 241                    zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
 242                                 orig_arg_tys arg_stricts
 243
 244         -- Representation arguments and demands
 245     (rep_arg_demands, rep_arg_tys)
 246         = unzip $ concat $
 247           zipWithEqual "mkDataCon2" unbox_strict_arg_ty
 248                        real_stricts
 249                        (ex_dict_tys ++ orig_arg_tys)
 250
 251     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
 252     ty  = mkForAllTys (tyvars ++ ex_tyvars)
 253                       (mkFunTys rep_arg_tys result_ty)
 254                 -- NB: the existential dict args are already in rep_arg_tys
 255
 256     result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
 257
 258 mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
 259                        | otherwise       = NotMarkedStrict
 260 \end{code}
 261
 262 \begin{code}
 263 dataConName :: DataCon -> Name
 264 dataConName = dcName
 265
 266 dataConTag :: DataCon -> ConTag
 267 dataConTag  = dcTag
 268
 269 dataConTyCon :: DataCon -> TyCon
 270 dataConTyCon = dcTyCon
 271
 272 dataConRepType :: DataCon -> Type
 273 dataConRepType = dcRepType
 274
 275 dataConId :: DataCon -> Id
 276 dataConId = dcId
 277
 278 dataConWrapId :: DataCon -> Id
 279 dataConWrapId = dcWrapId
 280
 281 dataConFieldLabels :: DataCon -> [FieldLabel]
 282 dataConFieldLabels = dcFields
 283
 284 dataConStrictMarks :: DataCon -> [StrictnessMark]
 285 dataConStrictMarks = dcStrictMarks
 286
 287 -- Number of type-instantiation arguments
 288 -- All the remaining arguments of the DataCon are (notionally)
 289 -- stored in the DataCon, and are matched in a case expression
 290 dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
 291
 292 dataConSourceArity :: DataCon -> Arity
 293         -- Source-level arity of the data constructor
 294 dataConSourceArity dc = length (dcOrigArgTys dc)
 295
 296 -- dataConRepArity gives the number of actual fields in the
 297 -- {\em representation} of the data constructor.  This may be more than appear
 298 -- in the source code; the extra ones are the existentially quantified
 299 -- dictionaries
 300 dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
 301
 302 isNullaryDataCon con  = dataConRepArity con == 0
 303
 304 dataConRepStrictness :: DataCon -> [Demand]
 305         -- Give the demands on the arguments of a
 306         -- Core constructor application (Con dc args)
 307 dataConRepStrictness dc = dcRepStrictness dc
 308
 309 dataConSig :: DataCon -> ([TyVar], ThetaType,
 310                           [TyVar], ThetaType,
 311                           [TauType], TyCon)
 312
 313 dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
 314                      dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
 315                      dcOrigArgTys = arg_tys, dcTyCon = tycon})
 316   = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
 317
 318 dataConArgTys :: DataCon
 319               -> [Type]         -- Instantiated at these types
 320                                 -- NB: these INCLUDE the existentially quantified arg types
 321               -> [Type]         -- Needs arguments of these types
 322                                 -- NB: these INCLUDE the existentially quantified dict args
 323                                 --     but EXCLUDE the data-decl context which is discarded
 324                                 -- It's all post-flattening etc; this is a representation type
 325
 326 dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
 327                        dcExTyVars = ex_tyvars}) inst_tys
 328  = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
 329
 330 dataConTheta :: DataCon -> ThetaType
 331 dataConTheta dc = dcTheta dc
 332
 333 -- And the same deal for the original arg tys:
 334
 335 dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
 336 dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
 337                        dcExTyVars = ex_tyvars}) inst_tys
 338  = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
 339 \end{code}
 340
 341 These two functions get the real argument types of the constructor,
 342 without substituting for any type variables.
 343
 344 dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args.
 345
 346 dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and
 347 after any flattening has been done.
 348
 349 \begin{code}
 350 dataConOrigArgTys :: DataCon -> [Type]
 351 dataConOrigArgTys dc = dcOrigArgTys dc
 352
 353 dataConRepArgTys :: DataCon -> [TauType]
 354 dataConRepArgTys dc = dcRepArgTys dc
 355 \end{code}
 356
 357
 358 \begin{code}
 359 isTupleCon :: DataCon -> Bool
 360 isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
 361
 362 isUnboxedTupleCon :: DataCon -> Bool
 363 isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
 364
 365 isExistentialDataCon :: DataCon -> Bool
 366 isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
 367 \end{code}
 368
 369
 370 \begin{code}
 371 classDataCon :: Class -> DataCon
 372 classDataCon clas = case tyConDataCons (classTyCon clas) of
 373                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
 374 \end{code}
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection{Splitting products}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 \begin{code}
 383 splitProductType_maybe
 384         :: Type                         -- A product type, perhaps
 385         -> Maybe (TyCon,                -- The type constructor
 386                   [Type],               -- Type args of the tycon
 387                   DataCon,              -- The data constructor
 388                   [Type])               -- Its *representation* arg types
 389
 390         -- Returns (Just ...) for any
 391         --      concrete (i.e. constructors visible)
 392         --      single-constructor
 393         --      not existentially quantified
 394         -- type whether a data type or a new type
 395         --
 396         -- Rejecing existentials is conservative.  Maybe some things
 397         -- could be made to work with them, but I'm not going to sweat
 398         -- it through till someone finds it's important.
 399
 400 splitProductType_maybe ty
 401   = case splitTyConApp_maybe ty of
 402         Just (tycon,ty_args)
 403            | isProductTyCon tycon       -- Includes check for non-existential,
 404                                         -- and for constructors visible
 405            -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
 406            where
 407               data_con = head (tyConDataConsIfAvailable tycon)
 408         other -> Nothing
 409
 410 splitProductType str ty
 411   = case splitProductType_maybe ty of
 412         Just stuff -> stuff
 413         Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 414
 415 -- We attempt to unbox/unpack a strict field when either:
 416 --   (i)  The tycon is imported, and the field is marked '! !', or
 417 --   (ii) The tycon is defined in this module, the field is marked '!',
 418 --        and the -funbox-strict-fields flag is on.
 419 --
 420 -- This ensures that if we compile some modules with -funbox-strict-fields and
 421 -- some without, the compiler doesn't get confused about the constructor
 422 -- representations.
 423
 424 chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
 425         -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
 426 chooseBoxingStrategy tycon arg_ty strict
 427   = case strict of
 428         MarkedUserStrict
 429           | opt_UnboxStrictFields
 430                 && unbox arg_ty -> MarkedUnboxed
 431           | otherwise -> MarkedStrict
 432         other -> strict
 433   where
 434         -- beware: repType will go into a loop if we try this on a recursive
 435         -- type (for reasons unknown...), hence the check for recursion below.
 436     unbox ty =
 437         case splitTyConApp_maybe ty of
 438                 Nothing -> False
 439                 Just (arg_tycon, _)
 440                   | isRecursiveTyCon arg_tycon -> False
 441                   | otherwise ->
 442                           case splitTyConApp_maybe (repType ty) of
 443                                 Nothing -> False
 444                                 Just (arg_tycon, _) -> isProductTyCon arg_tycon
 445
 446 unbox_strict_arg_ty
 447         :: StrictnessMark       -- After strategy choice; can't be MarkedUserStrict
 448         -> Type                 -- Source argument type
 449         -> [(Demand,Type)]      -- Representation argument types and demamds
 450
 451 unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)]
 452 unbox_strict_arg_ty MarkedStrict    ty = [(seqDmd,  ty)]
 453 unbox_strict_arg_ty MarkedUnboxed   ty
 454   = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
 455   where
 456     (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
 457 \end{code}