ConTag, fIRST_TAG,
mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
- dataConArgTys, dataConOrigArgTys,
+ dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
dataConRepArgTys, dataConTheta,
- dataConFieldLabels, dataConStrictMarks,
+ dataConFieldLabels, dataConStrictMarks,
dataConSourceArity, dataConRepArity,
dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
- isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isDynDataCon,
- isExistentialDataCon,
+ isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
+ isExistentialDataCon, classDataCon,
splitProductType_maybe, splitProductType,
import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
import CmdLineOpts ( opt_DictsStrict )
-import TysPrim
-import Type ( Type, ThetaType, TauType, ClassContext,
- mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, mkDictTy,
- splitAlgTyConApp_maybe, classesToPreds
+import Type ( Type, TauType, ClassContext,
+ mkForAllTys, mkFunTys, mkTyConApp,
+ mkTyVarTys, mkDictTys,
+ splitTyConApp_maybe
)
-import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
+import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
-import Class ( classTyCon )
-import Name ( Name, NamedThing(..), nameUnique, isDynName, isLocallyDefined )
+import Class ( Class, classTyCon )
+import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
import BasicTypes ( Arity )
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
import PprType () -- Instances
-import UniqSet
import Maybes ( maybeToBool )
import Maybe
-import Util ( assoc )
+import ListSetOps ( assoc )
\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,
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
- dcRepType :: Type, -- Type of the constructor
+ dcRepType :: Type, -- Type of the constructor
-- forall ab . Ord b => a -> [b] -> MkT a
- -- (this is *not* of the constructor Id:
+ -- (this is *not* of the constructor Id:
-- see notes after this data type declaration)
-- The next six fields express the type of the constructor, in pieces
-- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars and context for the data type decl
- -- These are ALWAYS THE SAME AS THE TYVARS
+ -- 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,
+ dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
dcExTheta :: ClassContext, -- the existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening,
-- and including existential dictionaries
- dcTyCon :: TyCon, -- Result tycon
+ dcTyCon :: TyCon, -- Result tycon
-- Now the strictness annotations and field labels of the constructor
- dcUserStricts :: [StrictnessMark],
+ dcUserStricts :: [StrictnessMark],
-- Strictness annotations, as placed on the data type defn,
-- in the same order as the argument types;
-- length = dataConSourceArity dataCon
-> 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)
-- The 'stricts' passed to mkDataCon are simply those for the
con
where
con = MkData {dcName = name, dcUnique = nameUnique name,
- dcTyVars = tyvars, dcTheta = theta,
- dcOrigArgTys = orig_arg_tys,
+ dcTyVars = tyvars, dcTheta = theta,
+ dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcRealStricts = all_stricts, dcUserStricts = user_stricts,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
dcId = work_id, dcWrapId = wrap_id}
- (real_arg_stricts, strict_arg_tyss)
+ (real_arg_stricts, strict_arg_tyss)
= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
- rep_arg_tys = [mkDictTy cls tys | (cls,tys) <- ex_theta] ++ concat strict_arg_tyss
+ 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
user_stricts = ex_dict_stricts ++ arg_stricts
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
isNullaryDataCon con = dataConRepArity con == 0
dataConRepStrictness :: DataCon -> [Demand]
- -- Give the demands on the arguments of a
+ -- Give the demands on the arguments of a
-- Core constructor application (Con dc args)
dataConRepStrictness dc
- = go (dcRealStricts dc)
+ = go (dcRealStricts dc)
where
go [] = []
go (MarkedStrict : ss) = wwStrict : go ss
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
-dataConTheta (MkData {dcTheta = theta}) = theta
+dataConTheta :: DataCon -> ClassContext
+dataConTheta dc = dcTheta dc
+
+-- And the same deal for the original arg tys:
+
+dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
+ dcExTyVars = ex_tyvars}) inst_tys
+ = map (substTy (mkTyVarSubst (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.
isExistentialDataCon :: DataCon -> Bool
isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
-
-isDynDataCon :: DataCon -> Bool
-isDynDataCon con = isDynName (dataConName con)
\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
-- type whether a data type or a new type
-- it through till someone finds it's important.
splitProductType_maybe ty
- = case splitAlgTyConApp_maybe ty of
- Just (tycon,ty_args,[data_con])
- | isProductTyCon tycon -- Includes check for non-existential
+ = case splitTyConApp_maybe ty of
+ 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)
other -> Nothing
splitProductType str 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
unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
unbox_strict_arg_ty tycon strict_mark ty
- | case strict_mark of
+ | case strict_mark of
NotMarkedStrict -> False
- MarkedUnboxed _ _ -> True
- MarkedStrict -> opt_UnboxStrictFields &&
- isLocallyDefined tycon &&
+ MarkedUnboxed _ _ -> True -- !! From interface file
+ MarkedStrict -> opt_UnboxStrictFields && -- ! From source
maybeToBool maybe_product &&
not (isRecursiveTyCon tycon) &&
isDataTyCon arg_tycon
maybe_product = splitProductType_maybe ty
Just (arg_tycon, _, con, arg_tys) = maybe_product
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff