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( substTy, mkTyVarSubst )
  26
  27 import CmdLineOpts      ( opt_DictsStrict )
  28 import Type             ( Type, TauType, ThetaType,
  29                           mkForAllTys, mkFunTys, mkTyConApp,
  30                           mkTyVarTys, splitTyConApp_maybe, repType
  31                         )
  32 import TcType           ( isStrictPred, mkPredTys )
  33 import TyCon            ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
  34                           isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
  35 import Class            ( Class, classTyCon )
  36 import Name             ( Name, NamedThing(..), nameUnique )
  37 import Var              ( TyVar, Id )
  38 import FieldLabel       ( FieldLabel )
  39 import BasicTypes       ( Arity )
  40 import Demand           ( Demand, StrictnessMark(..), wwStrict, wwLazy )
  41 import Outputable
  42 import Unique           ( Unique, Uniquable(..) )
  43 import CmdLineOpts      ( opt_UnboxStrictFields )
  44 import PprType          ()      -- Instances
  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     real_stricts = (map mk_dict_strict_mark ex_theta) ++
 240                    zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
 241                                 orig_arg_tys arg_stricts
 242
 243         -- Representation arguments and demands
 244     (rep_arg_demands, rep_arg_tys)
 245         = unzip $ concat $
 246           zipWithEqual "mkDataCon2" unbox_strict_arg_ty
 247                        real_stricts
 248                        (mkPredTys ex_theta ++ orig_arg_tys)
 249
 250     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
 251     ty  = mkForAllTys (tyvars ++ ex_tyvars)
 252                       (mkFunTys rep_arg_tys result_ty)
 253                 -- NB: the existential dict args are already in rep_arg_tys
 254
 255     result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
 256
 257 mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
 258                          | otherwise         = NotMarkedStrict
 259 \end{code}
 260
 261 \begin{code}
 262 dataConName :: DataCon -> Name
 263 dataConName = dcName
 264
 265 dataConTag :: DataCon -> ConTag
 266 dataConTag  = dcTag
 267
 268 dataConTyCon :: DataCon -> TyCon
 269 dataConTyCon = dcTyCon
 270
 271 dataConRepType :: DataCon -> Type
 272 dataConRepType = dcRepType
 273
 274 dataConId :: DataCon -> Id
 275 dataConId = dcId
 276
 277 dataConWrapId :: DataCon -> Id
 278 dataConWrapId = dcWrapId
 279
 280 dataConFieldLabels :: DataCon -> [FieldLabel]
 281 dataConFieldLabels = dcFields
 282
 283 dataConStrictMarks :: DataCon -> [StrictnessMark]
 284 dataConStrictMarks = dcStrictMarks
 285
 286 -- Number of type-instantiation arguments
 287 -- All the remaining arguments of the DataCon are (notionally)
 288 -- stored in the DataCon, and are matched in a case expression
 289 dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
 290
 291 dataConSourceArity :: DataCon -> Arity
 292         -- Source-level arity of the data constructor
 293 dataConSourceArity dc = length (dcOrigArgTys dc)
 294
 295 -- dataConRepArity gives the number of actual fields in the
 296 -- {\em representation} of the data constructor.  This may be more than appear
 297 -- in the source code; the extra ones are the existentially quantified
 298 -- dictionaries
 299 dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
 300
 301 isNullaryDataCon con  = dataConRepArity con == 0
 302
 303 dataConRepStrictness :: DataCon -> [Demand]
 304         -- Give the demands on the arguments of a
 305         -- Core constructor application (Con dc args)
 306 dataConRepStrictness dc = dcRepStrictness dc
 307
 308 dataConSig :: DataCon -> ([TyVar], ThetaType,
 309                           [TyVar], ThetaType,
 310                           [TauType], TyCon)
 311
 312 dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
 313                      dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
 314                      dcOrigArgTys = arg_tys, dcTyCon = tycon})
 315   = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
 316
 317 dataConArgTys :: DataCon
 318               -> [Type]         -- Instantiated at these types
 319                                 -- NB: these INCLUDE the existentially quantified arg types
 320               -> [Type]         -- Needs arguments of these types
 321                                 -- NB: these INCLUDE the existentially quantified dict args
 322                                 --     but EXCLUDE the data-decl context which is discarded
 323                                 -- It's all post-flattening etc; this is a representation type
 324
 325 dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
 326                        dcExTyVars = ex_tyvars}) inst_tys
 327  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 328
 329 dataConTheta :: DataCon -> ThetaType
 330 dataConTheta dc = dcTheta dc
 331
 332 -- And the same deal for the original arg tys:
 333
 334 dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
 335 dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
 336                        dcExTyVars = ex_tyvars}) inst_tys
 337  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 338 \end{code}
 339
 340 These two functions get the real argument types of the constructor,
 341 without substituting for any type variables.
 342
 343 dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args.
 344
 345 dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and
 346 after any flattening has been done.
 347
 348 \begin{code}
 349 dataConOrigArgTys :: DataCon -> [Type]
 350 dataConOrigArgTys dc = dcOrigArgTys dc
 351
 352 dataConRepArgTys :: DataCon -> [TauType]
 353 dataConRepArgTys dc = dcRepArgTys dc
 354 \end{code}
 355
 356
 357 \begin{code}
 358 isTupleCon :: DataCon -> Bool
 359 isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
 360
 361 isUnboxedTupleCon :: DataCon -> Bool
 362 isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
 363
 364 isExistentialDataCon :: DataCon -> Bool
 365 isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
 366 \end{code}
 367
 368
 369 \begin{code}
 370 classDataCon :: Class -> DataCon
 371 classDataCon clas = case tyConDataCons (classTyCon clas) of
 372                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
 373 \end{code}
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection{Splitting products}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 \begin{code}
 382 splitProductType_maybe
 383         :: Type                         -- A product type, perhaps
 384         -> Maybe (TyCon,                -- The type constructor
 385                   [Type],               -- Type args of the tycon
 386                   DataCon,              -- The data constructor
 387                   [Type])               -- Its *representation* arg types
 388
 389         -- Returns (Just ...) for any
 390         --      concrete (i.e. constructors visible)
 391         --      single-constructor
 392         --      not existentially quantified
 393         -- type whether a data type or a new type
 394         --
 395         -- Rejecing existentials is conservative.  Maybe some things
 396         -- could be made to work with them, but I'm not going to sweat
 397         -- it through till someone finds it's important.
 398
 399 splitProductType_maybe ty
 400   = case splitTyConApp_maybe ty of
 401         Just (tycon,ty_args)
 402            | isProductTyCon tycon       -- Includes check for non-existential,
 403                                         -- and for constructors visible
 404            -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
 405            where
 406               data_con = head (tyConDataConsIfAvailable tycon)
 407         other -> Nothing
 408
 409 splitProductType str ty
 410   = case splitProductType_maybe ty of
 411         Just stuff -> stuff
 412         Nothing    -> pprPanic (str ++ ": not a product") (ppr ty)
 413
 414 -- We attempt to unbox/unpack a strict field when either:
 415 --   (i)  The tycon is imported, and the field is marked '! !', or
 416 --   (ii) The tycon is defined in this module, the field is marked '!',
 417 --        and the -funbox-strict-fields flag is on.
 418 --
 419 -- This ensures that if we compile some modules with -funbox-strict-fields and
 420 -- some without, the compiler doesn't get confused about the constructor
 421 -- representations.
 422
 423 chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
 424         -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
 425 chooseBoxingStrategy tycon arg_ty strict
 426   = case strict of
 427         MarkedUserStrict
 428           | opt_UnboxStrictFields
 429                 && unbox arg_ty -> MarkedUnboxed
 430           | otherwise -> MarkedStrict
 431         other -> strict
 432   where
 433         -- beware: repType will go into a loop if we try this on a recursive
 434         -- type (for reasons unknown...), hence the check for recursion below.
 435     unbox ty =
 436         case splitTyConApp_maybe ty of
 437                 Nothing -> False
 438                 Just (arg_tycon, _)
 439                   | isRecursiveTyCon arg_tycon -> False
 440                   | otherwise ->
 441                           case splitTyConApp_maybe (repType ty) of
 442                                 Nothing -> False
 443                                 Just (arg_tycon, _) -> isProductTyCon arg_tycon
 444
 445 unbox_strict_arg_ty
 446         :: StrictnessMark       -- After strategy choice; can't be MkaredUserStrict
 447         -> Type                 -- Source argument type
 448         -> [(Demand,Type)]      -- Representation argument types and demamds
 449
 450 unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy,   ty)]
 451 unbox_strict_arg_ty MarkedStrict    ty = [(wwStrict, ty)]
 452 unbox_strict_arg_ty MarkedUnboxed   ty
 453   = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
 454   where
 455     (_, _, arg_data_con, arg_tys)
 456          = splitProductType "unbox_strict_arg_ty" (repType ty)
 457 \end{code}