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