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