X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FDataCon.lhs;h=175427ac83d6179023aba8a05c66e34021c542b0;hb=8f0c89cbbbad60c4f05356fcb9053b7ed0c18075;hp=3ecd9689e692c81837478f3820b49cbd1ca1bd23;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 3ecd968..175427a 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -1,43 +1,104 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1998 % -\section[Literal]{@Literal@: Machine literals (unboxed, of course)} +\section[DataCon]{@DataCon@: Data Constructors} \begin{code} module DataCon ( DataCon, ConTag, fIRST_TAG, mkDataCon, - dataConType, dataConSig, dataConName, dataConTag, - dataConArgTys, dataConRawArgTys, dataConTyCon, - dataConFieldLabels, dataConStrictMarks, dataConSourceArity, - dataConNumFields, dataConNumInstArgs, dataConId, + dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, + dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys, + dataConRepArgTys, dataConTheta, + dataConFieldLabels, dataConStrictMarks, + dataConSourceArity, dataConRepArity, + dataConNumInstArgs, dataConWorkId, dataConWrapId, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon + isExistentialDataCon, classDataCon, dataConExistentialTyVars, + + splitProductType_maybe, splitProductType, ) where #include "HsVersions.h" -import CmdLineOpts ( opt_DictsStrict ) -import TysPrim -import Type ( Type, ThetaType, TauType, - mkSigmaTy, mkFunTys, mkTyConApp, - mkTyVarTys, mkDictTy, substTy +import {-# SOURCE #-} Subst( substTyWith ) +import {-# SOURCE #-} PprType( pprType ) + +import Type ( Type, ThetaType, + mkForAllTys, mkFunTys, mkTyConApp, + mkTyVarTys, splitTyConApp_maybe, repType, + mkPredTys, isStrictType ) -import TyCon ( TyCon, tyConDataCons, isDataTyCon, - isTupleTyCon, isUnboxedTupleTyCon ) -import Class ( classTyCon ) +import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) +import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) -import VarEnv import FieldLabel ( FieldLabel ) -import BasicTypes ( StrictnessMark(..), Arity ) +import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) -import Util ( assoc ) +import CmdLineOpts ( opt_UnboxStrictFields ) +import Maybe +import ListSetOps ( assoc ) +import Util ( zipEqual, zipWithEqual, equalLength, notNull ) \end{code} +Stuff about data constructors +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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, + and it gets a top-level binding like any other function + + *worker*, called $wC, which is the actual data constructor. + Its type may be different to C, because: + - useless dict args are dropped + - strict args may be flattened + It does not have a binding. + + 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. + + + %************************************************************************ %* * \subsection{Data constructors} @@ -56,10 +117,19 @@ data DataCon -- -- data Eq a => T a = forall b. Ord b => MkT a [b] - dcType :: 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. @@ -68,32 +138,64 @@ data DataCon -- dcTheta = [Eq a] -- dcExTyVars = [b] -- dcExTheta = [Ord b] - -- dcArgTys = [a,List b] + -- dcOrigArgTys = [a,List b] -- dcTyCon = T - dcTyVars :: [TyVar], -- Type vars and context for the data type decl - dcTheta :: ThetaType, - - dcExTyVars :: [TyVar], -- Ditto for the context of the constructor, + 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 + + 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 - dcArgTys :: [Type], -- Argument types - dcTyCon :: TyCon, -- Result tycon + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of + -- strict fields) - -- Now the strictness annotations and field labels of the constructor - dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types; - -- length = dataConNumFields dataCon + dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, + -- and including existential dictionaries + + dcRepStrictness :: [StrictnessMark], -- One for each representation argument - dcFields :: [FieldLabel], -- Field labels for this constructor, in the - -- same order as the argument types; - -- length = 0 (if not a record) or dataConSourceArity. + dcTyCon :: TyCon, -- Result tycon - -- Finally, the curried function that corresponds to the constructor - -- mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a - -- mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs] - -- This unfolding is built in MkId.mkDataConId + -- Now the strictness annotations and field labels of the constructor + 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], + -- Field labels for this constructor, in the + -- same order as the argument types; + -- length = 0 (if not a record) or dataConSourceArity. + + -- Finally, the curried worker function that corresponds to the constructor + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + -- + -- An entirely separate wrapper function is built in TcTyDecls - dcId :: Id -- The corresponding Id + dcWorkId :: Id, -- The corresponding worker Id + -- Takes dcRepArgTys as its arguments + + dcWrapId :: Id -- The wrapper Id } type ConTag = Int @@ -102,7 +204,7 @@ fIRST_TAG :: ConTag fIRST_TAG = 1 -- Tags allocated from here for real constructors \end{code} -The dcType field contains the type of the representation of a contructor +The dcRepType field contains the type of the representation of a contructor This may differ from the type of the contructor *Id* (built by MkId.mkDataConId) for two reasons: a) the constructor Id may be overloaded, but the dictionary isn't stored @@ -119,6 +221,12 @@ but the rep type is Actually, the unboxed part isn't implemented yet! +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + \begin{code} instance Eq DataCon where a == b = getUnique a == getUnique b @@ -144,44 +252,63 @@ instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) \end{code} + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType - -> [TauType] -> TyCon - -> Id + -> [Type] -> TyCon + -> Id -> Id -> DataCon -- Can get the tag from the TyCon -mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta arg_tys tycon id - = ASSERT(length arg_stricts == length arg_tys) +mkDataCon name arg_stricts fields + tyvars theta ex_tyvars ex_theta orig_arg_tys tycon + work_id wrap_id + = 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, dcArgTys = arg_tys, + dcTyVars = tyvars, dcStupidTheta = theta, + dcOrigArgTys = orig_arg_tys, + dcRepArgTys = rep_arg_tys, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcStricts = all_stricts, dcFields = fields, - dcTag = tag, dcTyCon = tycon, dcType = ty, - dcId = id} - - all_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts - -- Add a strictness flag for the existential dictionary arguments + dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts, + dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty, + dcWorkId = work_id, dcWrapId = wrap_id} + + -- 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 = mkSigmaTy (tyvars ++ ex_tyvars) - ex_theta - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) - -mk_dict_strict_mark (clas,tys) - | opt_DictsStrict && - isDataTyCon (classTyCon clas) = MarkedStrict -- Don't mark newtype things as strict! - | otherwise = NotMarkedStrict -\end{code} + 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 ty | isStrictType ty = MarkedStrict + | otherwise = NotMarkedStrict +\end{code} \begin{code} dataConName :: DataCon -> Name @@ -193,65 +320,96 @@ dataConTag = dcTag dataConTyCon :: DataCon -> TyCon dataConTyCon = dcTyCon -dataConType :: DataCon -> Type -dataConType = dcType +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType -dataConId :: DataCon -> Id -dataConId = dcId +dataConWorkId :: DataCon -> Id +dataConWorkId = dcWorkId +dataConWrapId :: DataCon -> Id +dataConWrapId = dcWrapId dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks = dcStricts +dataConStrictMarks = dcStrictMarks -dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience -dataConRawArgTys = dcArgTys +-- Number of type-instantiation arguments +-- All the remaining arguments of the DataCon are (notionally) +-- stored in the DataCon, and are matched in a case expression +dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor -dataConSourceArity dc = length (dcArgTys dc) +dataConSourceArity dc = length (dcOrigArgTys dc) + +-- dataConRepArity gives the number of actual fields in the +-- {\em representation} of the data constructor. This may be more than appear +-- in the source code; the extra ones are the existentially quantified +-- dictionaries +dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys + +isNullaryDataCon con = dataConRepArity con == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] + -- Give the demands on the arguments of a + -- Core constructor application (Con dc args) +dataConRepStrictness dc = dcRepStrictness dc -dataConSig :: DataCon -> ([TyVar], ThetaType, - [TyVar], ThetaType, - [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, - dcArgTys = arg_tys, dcTyCon = tycon}) + 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 -- NB: these INCLUDE the existentially quantified dict args -- but EXCLUDE the data-decl context which is discarded + -- It's all post-flattening etc; this is a representation type -dataConArgTys (MkData {dcArgTys = arg_tys, dcTyVars = tyvars, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys - = map (substTy (zipVarEnv (tyvars ++ ex_tyvars) inst_tys)) - ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys) +dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, + dcExTyVars = ex_tyvars}) inst_tys + = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys + +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, + dcExTyVars = ex_tyvars}) inst_tys + = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys \end{code} -dataConNumFields gives the number of actual fields in the -{\em representation} of the data constructor. This may be more than appear -in the source code; the extra ones are the existentially quantified -dictionaries +These two functions get the real argument types of the constructor, +without substituting for any type variables. + +dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args. + +dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and +after any flattening has been done. \begin{code} --- Number of type-instantiation arguments --- All the remaining arguments of the DataCon are (notionally) --- stored in the DataCon, and are matched in a case expression -dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc -dataConNumFields (MkData {dcExTheta = theta, dcArgTys = arg_tys}) - = length theta + length arg_tys +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys dc = dcRepArgTys dc +\end{code} -isNullaryDataCon con - = dataConNumFields con == 0 -- function of convenience +\begin{code} isTupleCon :: DataCon -> Bool isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc @@ -259,5 +417,98 @@ isUnboxedTupleCon :: DataCon -> Bool 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} +splitProductType_maybe + :: Type -- A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its *representation* arg types + + -- Returns (Just ...) for any + -- concrete (i.e. constructors visible) + -- single-constructor + -- not existentially quantified + -- type whether a data type or a new type + -- + -- Rejecing existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitProductType_maybe ty + = 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 (tyConDataCons tycon) + other -> Nothing + +splitProductType str ty + = case splitProductType_maybe ty of + Just stuff -> stuff + 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 '!', +-- 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. + +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 + 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}