mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
- dataConRepArgTys, dataConTheta,
- dataConFieldLabels, dataConStrictMarks,
+ dataConRepArgTys, dataConTheta,
+ dataConFieldLabels, dataConStrictMarks,
dataConSourceArity, dataConRepArity,
- dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
- isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
- isExistentialDataCon,
+ dataConNumInstArgs, dataConWorkId, dataConWrapId, dataConRepStrictness,
+ isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
+ isExistentialDataCon, classDataCon, dataConExistentialTyVars,
splitProductType_maybe, splitProductType,
-
- StrictnessMark(..), -- Representation visible to MkId only
- markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
+import {-# SOURCE #-} Subst( substTyWith )
+import {-# SOURCE #-} PprType( pprType )
-import CmdLineOpts ( opt_DictsStrict )
-import Type ( Type, ThetaType, TauType, ClassContext,
- mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, mkDictTys,
- splitTyConApp_maybe, classesToPreds
+import Type ( Type, ThetaType,
+ mkForAllTys, mkFunTys, mkTyConApp,
+ mkTyVarTys, splitTyConApp_maybe, repType,
+ mkPredTys, isStrictType
)
-import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
+import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
-import Class ( classTyCon )
-import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined )
+import Class ( Class, classTyCon )
+import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
-import BasicTypes ( Arity )
-import Demand ( Demand, wwStrict, wwLazy )
+import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
-import PprType () -- Instances
-import Maybes ( maybeToBool )
import Maybe
import ListSetOps ( assoc )
+import Util ( zipEqual, zipWithEqual, equalLength, notNull )
\end{code}
Stuff about data constructors
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Every constructor, C, comes with a
+Every constructor, C, comes with a
*wrapper*, called C, whose type is exactly what it looks like
in the source program. It is an ordinary function,
The worker is very like a primop, in that it has no binding,
+A note about the stupid context
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Data types can have a context:
+
+ data (Eq a, Ord b) => T a b = T1 a b | T2 a
+
+and that makes the constructors have a context too
+(notice that T2's context is "thinned"):
+
+ T1 :: (Eq a, Ord b) => a -> b -> T a b
+ T2 :: (Eq a) => a -> T a b
+
+Furthermore, this context pops up when pattern matching
+(though GHC hasn't implemented this, but it is in H98, and
+I've fixed GHC so that it now does):
+
+ f (T2 x) = x
+gets inferred type
+ f :: Eq a => T a b -> a
+
+I say the context is "stupid" because the dictionaries passed
+are immediately discarded -- they do nothing and have no benefit.
+It's a flaw in the language.
+
+Up to now [March 2002] I have put this stupid context into the type of
+the "wrapper" constructors functions, T1 and T2, but that turned out
+to be jolly inconvenient for generics, and record update, and other
+functions that build values of type T (because they don't have
+suitable dictionaries available).
+
+So now I've taken the stupid context out. I simply deal with it
+separately in the type checker on occurrences of a constructor, either
+in an expression or in a pattern.
+
+
%************************************************************************
%* *
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
- dcRepType :: Type, -- Type of the constructor
- -- forall ab . Ord b => a -> [b] -> MkT a
- -- (this is *not* of the constructor Id:
+ dcRepType :: Type, -- Type of the constructor
+ -- forall a b . Ord b => a -> [b] -> MkT a
+ -- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
+ --
+ -- Notice that the existential type parameters come *second*.
+ -- Reason: in a case expression we may find:
+ -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
+ -- It's convenient to apply the rep-type of MkT to 't', to get
+ -- forall b. Ord b => ...
+ -- and use that to check the pattern. Mind you, this is really only
+ -- use in CoreLint.
+
-- The next six fields express the type of the constructor, in pieces
-- e.g.
-- dcOrigArgTys = [a,List b]
-- dcTyCon = T
- dcTyVars :: [TyVar], -- Type vars and context for the data type decl
- -- These are ALWAYS THE SAME AS THE TYVARS
+ dcTyVars :: [TyVar], -- Type vars for the data type decl
+ -- These are ALWAYS THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. We occasionally rely on
-- this just to avoid redundant instantiation
- dcTheta :: ClassContext,
- dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
- dcExTheta :: ClassContext, -- the existentially quantified stuff
+ dcStupidTheta :: ThetaType, -- This is a "thinned" version of the context of
+ -- the data decl.
+ -- "Thinned", because the Report says
+ -- to eliminate any constraints that don't mention
+ -- tyvars free in the arg types for this constructor
+ --
+ -- "Stupid", because the dictionaries aren't used for anything.
+ --
+ -- Indeed, [as of March 02] they are no
+ -- longer in the type of the dataConWrapId, because
+ -- that makes it harder to use the wrap-id to rebuild
+ -- values after record selection or in generics.
+
+ dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
+ dcExTheta :: ThetaType, -- the existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening,
-- and including existential dictionaries
+ dcRepStrictness :: [StrictnessMark], -- One for each representation argument
+
dcTyCon :: TyCon, -- Result tycon
-- Now the strictness annotations and field labels of the constructor
- dcUserStricts :: [StrictnessMark],
- -- Strictness annotations, as placed on the data type defn,
- -- in the same order as the argument types;
- -- length = dataConSourceArity dataCon
-
- dcRealStricts :: [StrictnessMark],
- -- Strictness annotations as deduced by the compiler. May
- -- include some MarkedUnboxed fields that are merely MarkedStrict
- -- in dcUserStricts. Also includes the existential dictionaries.
+ dcStrictMarks :: [StrictnessMark],
+ -- Strictness annotations as deduced by the compiler.
+ -- Has no MarkedUserStrict; they have been changed to MarkedStrict
+ -- or MarkedUnboxed by the compiler.
+ -- *Includes the existential dictionaries*
-- length = length dcExTheta + dataConSourceArity dataCon
dcFields :: [FieldLabel],
--
-- An entirely separate wrapper function is built in TcTyDecls
- dcId :: Id, -- The corresponding worker Id
+ dcWorkId :: Id, -- The corresponding worker Id
-- Takes dcRepArgTys as its arguments
dcWrapId :: Id -- The wrapper Id
%************************************************************************
%* *
-\subsection{Strictness indication}
-%* *
-%************************************************************************
-
-\begin{code}
-data StrictnessMark = MarkedStrict
- | MarkedUnboxed DataCon [Type]
- | NotMarkedStrict
-
-markedStrict = MarkedStrict
-notMarkedStrict = NotMarkedStrict
-markedUnboxed = MarkedUnboxed (panic "markedUnboxed1") (panic "markedUnboxed2")
-
-maybeMarkedUnboxed (MarkedUnboxed dc tys) = Just (dc,tys)
-maybeMarkedUnboxed other = Nothing
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Instances}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection{Consruction}
+\subsection{Construction}
%* *
%************************************************************************
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ClassContext
- -> [TyVar] -> ClassContext
- -> [TauType] -> TyCon
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [Type] -> TyCon
-> Id -> Id
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name arg_stricts fields
- tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
+mkDataCon name arg_stricts fields
+ tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
work_id wrap_id
- = ASSERT(length arg_stricts == length orig_arg_tys)
+ = ASSERT(equalLength arg_stricts orig_arg_tys)
-- The 'stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
con
where
con = MkData {dcName = name, dcUnique = nameUnique name,
- dcTyVars = tyvars, dcTheta = theta,
- dcOrigArgTys = orig_arg_tys,
+ dcTyVars = tyvars, dcStupidTheta = theta,
+ dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
- dcRealStricts = all_stricts, dcUserStricts = user_stricts,
+ dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
- dcId = work_id, dcWrapId = wrap_id}
+ dcWorkId = work_id, dcWrapId = wrap_id}
- (real_arg_stricts, strict_arg_tyss)
- = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
- rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss
-
- ex_dict_stricts = map mk_dict_strict_mark ex_theta
- -- Add a strictness flag for the existential dictionary arguments
- all_stricts = ex_dict_stricts ++ real_arg_stricts
- user_stricts = ex_dict_stricts ++ arg_stricts
+ -- Strictness marks for source-args
+ -- *after unboxing choices*,
+ -- but *including existential dictionaries*
+ ex_dict_tys = mkPredTys ex_theta
+ real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
+ zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
+ orig_arg_tys arg_stricts
+ real_arg_tys = ex_dict_tys ++ orig_arg_tys
+
+ -- Representation arguments and demands
+ (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
- ty = mkForAllTys (tyvars ++ ex_tyvars)
+ ty = mkForAllTys (tyvars ++ ex_tyvars)
(mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
-mk_dict_strict_mark (clas,tys)
- | opt_DictsStrict &&
- -- Don't mark newtype things as strict!
- isDataTyCon (classTyCon clas) = MarkedStrict
- | otherwise = NotMarkedStrict
+mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
+ | otherwise = NotMarkedStrict
\end{code}
\begin{code}
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
-dataConId :: DataCon -> Id
-dataConId = dcId
+dataConWorkId :: DataCon -> Id
+dataConWorkId = dcWorkId
dataConWrapId :: DataCon -> Id
dataConWrapId = dcWrapId
dataConFieldLabels = dcFields
dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks = dcRealStricts
+dataConStrictMarks = dcStrictMarks
-- Number of type-instantiation arguments
-- All the remaining arguments of the DataCon are (notionally)
isNullaryDataCon con = dataConRepArity con == 0
-dataConRepStrictness :: DataCon -> [Demand]
- -- Give the demands on the arguments of a
+dataConRepStrictness :: DataCon -> [StrictnessMark]
+ -- Give the demands on the arguments of a
-- Core constructor application (Con dc args)
-dataConRepStrictness dc
- = go (dcRealStricts dc)
- where
- go [] = []
- go (MarkedStrict : ss) = wwStrict : go ss
- go (NotMarkedStrict : ss) = wwLazy : go ss
- go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
+dataConRepStrictness dc = dcRepStrictness dc
-dataConSig :: DataCon -> ([TyVar], ClassContext,
- [TyVar], ClassContext,
- [TauType], TyCon)
+dataConSig :: DataCon -> ([TyVar], ThetaType,
+ [TyVar], ThetaType,
+ [Type], TyCon)
-dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
+dataConSig (MkData {dcTyVars = tyvars, dcStupidTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
-dataConArgTys :: DataCon
+dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified arg types
-> [Type] -- Needs arguments of these types
-- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type
-dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
+dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
-dataConTheta :: DataCon -> ClassContext
-dataConTheta dc = dcTheta dc
+dataConTheta :: DataCon -> ThetaType
+dataConTheta dc = dcStupidTheta dc
+
+dataConExistentialTyVars :: DataCon -> [TyVar]
+dataConExistentialTyVars dc = dcExTyVars dc
-- And the same deal for the original arg tys:
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
\end{code}
These two functions get the real argument types of the constructor,
-without substituting for any type variables.
+without substituting for any type variables.
dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args.
dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc
-dataConRepArgTys :: DataCon -> [TauType]
+dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys dc = dcRepArgTys dc
\end{code}
isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
isExistentialDataCon :: DataCon -> Bool
-isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
+isExistentialDataCon (MkData {dcExTyVars = tvs}) = notNull tvs
\end{code}
+\begin{code}
+classDataCon :: Class -> DataCon
+classDataCon clas = case tyConDataCons (classTyCon clas) of
+ (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
+\end{code}
+
%************************************************************************
%* *
\subsection{Splitting products}
%* *
%************************************************************************
-\begin{code}
+\begin{code}
splitProductType_maybe
:: Type -- A product type, perhaps
-> Maybe (TyCon, -- The type constructor
DataCon, -- The data constructor
[Type]) -- Its *representation* arg types
- -- Returns (Just ...) for any
+ -- Returns (Just ...) for any
-- concrete (i.e. constructors visible)
-- single-constructor
-- not existentially quantified
splitProductType_maybe ty
= case splitTyConApp_maybe ty of
- Just (tycon,ty_args)
+ Just (tycon,ty_args)
| isProductTyCon tycon -- Includes check for non-existential,
-- and for constructors visible
-> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
where
- data_con = head (tyConDataConsIfAvailable tycon)
+ data_con = head (tyConDataCons tycon)
other -> Nothing
splitProductType str ty
= case splitProductType_maybe ty of
Just stuff -> stuff
- Nothing -> pprPanic (str ++ ": not a product") (ppr ty)
+ Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-- We attempt to unbox/unpack a strict field when either:
-- (i) The tycon is imported, and the field is marked '! !', or
--- (ii) The tycon is defined in this module, the field is marked '!',
+-- (ii) The tycon is defined in this module, the field is marked '!',
-- and the -funbox-strict-fields flag is on.
--
-- This ensures that if we compile some modules with -funbox-strict-fields and
-- some without, the compiler doesn't get confused about the constructor
-- representations.
-unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
-
-unbox_strict_arg_ty tycon strict_mark ty
- | case strict_mark of
- NotMarkedStrict -> False
- MarkedUnboxed _ _ -> True
- MarkedStrict -> opt_UnboxStrictFields &&
- isLocallyDefined tycon &&
- maybeToBool maybe_product &&
- not (isRecursiveTyCon tycon) &&
- isDataTyCon arg_tycon
- -- We can't look through newtypes in arguments (yet)
- = (MarkedUnboxed con arg_tys, arg_tys)
-
- | otherwise
- = (strict_mark, [ty])
-
+chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
+ -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
+chooseBoxingStrategy tycon arg_ty strict
+ = case strict of
+ MarkedUserStrict
+ | opt_UnboxStrictFields
+ && unbox arg_ty -> MarkedUnboxed
+ | otherwise -> MarkedStrict
+ other -> strict
+ where
+ -- beware: repType will go into a loop if we try this on a recursive
+ -- type (for reasons unknown...), hence the check for recursion below.
+ unbox ty =
+ case splitTyConApp_maybe ty of
+ Nothing -> False
+ Just (arg_tycon, _)
+ | isRecursiveTyCon arg_tycon -> False
+ | otherwise ->
+ case splitTyConApp_maybe (repType ty) of
+ Nothing -> False
+ Just (arg_tycon, _) -> isProductTyCon arg_tycon
+
+computeRep :: [StrictnessMark] -- Original arg strictness
+ -- [after strategy choice; can't be MarkedUserStrict]
+ -> [Type] -- and types
+ -> ([StrictnessMark], -- Representation arg strictness
+ [Type]) -- And type
+
+computeRep stricts tys
+ = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
where
- maybe_product = splitProductType_maybe ty
- Just (arg_tycon, _, con, arg_tys) = maybe_product
+ unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
+ unbox MarkedStrict ty = [(MarkedStrict, ty)]
+ unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
+ where
+ (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
\end{code}
-
-