X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FDataCon.lhs;h=805ef73c597c1fbfdf752fcbe79b89afefa09406;hb=c5b03909e7c630a874f6f1abf76d28baf4b19d55;hp=d8c0935cb57cfa9e4f2e9f988c91d6514a9fa189;hpb=9d1775e3993cbca161c54116332ed56ce927fd51;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index d8c0935..805ef73 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -5,44 +5,169 @@ \begin{code} module DataCon ( - DataCon, + DataCon, DataConIds(..), ConTag, fIRST_TAG, mkDataCon, - dataConType, dataConSig, dataConName, dataConTag, - dataConOrigArgTys, dataConArgTys, dataConRawArgTys, dataConTyCon, - dataConFieldLabels, dataConStrictMarks, dataConSourceArity, - dataConNumFields, dataConNumInstArgs, dataConId, - isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon + dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, + dataConTyVars, dataConResTys, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConInstResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, + dataConStrictMarks, dataConExStricts, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, + dataConRepStrictness, + isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, + isVanillaDataCon, classDataCon, + + splitProductType_maybe, splitProductType, ) where #include "HsVersions.h" -import CmdLineOpts ( opt_DictsStrict ) -import TysPrim -import Type ( Type, ThetaType, TauType, - mkSigmaTy, mkFunTys, mkTyConApp, - mkTyVarTys, mkDictTy, substTy, - splitAlgTyConApp_maybe +import Type ( Type, ThetaType, substTyWith, substTy, zipOpenTvSubst, + mkForAllTys, mkFunTys, mkTyConApp, + splitTyConApp_maybe, + mkPredTys, isStrictPred, pprType ) -import PprType -import TyCon ( TyCon, tyConDataCons, isDataTyCon, - isTupleTyCon, isUnboxedTupleTyCon ) -import Class ( classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, isLocallyDefinedName ) +import TyCon ( TyCon, FieldLabel, tyConDataCons, + isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon ) +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 CmdLineOpts ( opt_UnboxStrictFields ) -import UniqSet -import Maybe -import Util ( assoc ) +import ListSetOps ( assoc ) +import Util ( zipEqual, zipWithEqual ) +import Maybes ( expectJust ) \end{code} +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly three, Names associated with it: + + OccName Name space Used for + --------------------------------------------------------------------------- + * The "source data con" C DataName The DataCon itself + * The "real data con" C VarName Its worker Id + * The "wrapper data con" $WC VarName Wrapper Id (optional) + +Each of these three has a distinct Unique. The "source data con" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + + The "worker Id", is the actual data constructor. + Its type may be different to the Haskell source constructor + because: + - useless dict args are dropped + - strict args may be flattened + The worker is very like a primop, in that it has no binding. + + Newtypes have no worker Id + + + The "wrapper Id", $WC, 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. + + The wrapper Id isn't generated for a data type if the worker + and wrapper are identical. It's always generated for a newtype. + + + +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. + + [May 2003: actually I think this decision could evasily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + %************************************************************************ %* * \subsection{Data constructors} @@ -51,75 +176,152 @@ import Util ( assoc ) \begin{code} data DataCon - = MkData { -- Used for data constructors only; - -- there *is* no constructor for a newtype - dcName :: Name, - dcUnique :: Unique, -- Cached from Name + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, -- Running example: -- -- 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: - -- see notes after this data type declaration) - -- The next six fields express the type of the constructor, in pieces -- e.g. -- - -- dcTyVars = [a] - -- dcTheta = [Eq a] - -- dcExTyVars = [b] - -- dcExTheta = [Ord 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, - dcExTheta :: ThetaType, -- the existentially quantified stuff + -- dcTyVars = [a,b] + -- dcStupidTheta = [Eq a] + -- dcTheta = [Ord b] + -- dcOrigArgTys = [a,List b] + -- dcTyCon = T + -- dcTyArgs = [a,b] + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no GADTs, nothing. + -- + -- NB1: the order of the forall'd variables does matter; + -- for a vanilla constructor, we assume that if the result + -- type is (T t1 ... tn) then we can instantiate the constr + -- at types [t1, ..., tn] + -- + -- NB2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + + dcTyVars :: [TyVar], -- Universally-quantified type vars + -- for the data constructor. + -- See NB1 on dcVanilla for the conneciton between dcTyVars and dcResTys + -- + -- In general, the dcTyVars are NOT NECESSARILY THE SAME AS THE TYVARS + -- FOR THE PARENT TyCon. With GADTs the data con might not even have + -- the same number of type variables. + -- [This is a change (Oct05): previously, vanilla datacons guaranteed to + -- have the same type variables as their parent TyCon, but that seems ugly.] + + 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 wrapper Id, because + -- that makes it harder to use the wrap-id to rebuild + -- values after record selection or in generics. + -- + -- Fact: the free tyvars of dcStupidTheta are a subset of + -- the free tyvars of dcResTys + -- Reason: dcStupidTeta is gotten by instantiating the + -- stupid theta from the tycon (see BuildTyCl.mkDataConStupidTheta) + + dcTheta :: ThetaType, -- The existentially quantified stuff dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of -- strict fields) - dcRepArgTys :: [Type], -- Constructor Argument types - 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 = dataConNumFields dataCon + -- Result type of constructor is T t1..tn + dcTyCon :: TyCon, -- Result tycon, T + dcResTys :: [Type], -- Result type args, t1..tn - dcRealStricts :: [StrictnessMark], - -- Strictness annotations as deduced by the compiler. May - -- include some MarkedUnboxed fields that are MarkedStrict - -- in dcUserStricts. - -- length = dataConNumFields dataCon + -- Now the strictness annotations and field labels of the constructor + dcStrictMarks :: [StrictnessMark], + -- Strictness annotations as decided by the compiler. + -- Does *not* include the existential dictionaries + -- length = 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 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 + -- Constructor representation + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* existential dictionaries - dcId :: Id -- The corresponding Id + dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + + 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. + + + -- 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 + dcIds :: DataConIds, + + dcInfix :: Bool -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere } +data DataConIds + = NewDC Id -- Newtypes have only a wrapper, but no worker + | AlgDC (Maybe Id) Id -- Algebraic data types always have a worker, and + -- may or may not have a wrapper, depending on whether + -- the wrapper does anything. + + -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + + -- The wrapper takes dcOrigArgTys as its arguments + -- The worker takes dcRepArgTys as its arguments + -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys + + -- The 'Nothing' case of AlgDC is important + -- Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker (becuase it *is* the wroker) + -- even when there are no args. E.g. in + -- f (:) x + -- the (:) *is* the worker. + -- This is really important in rule matching, + -- (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together.) + type ConTag = Int 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 @@ -136,6 +338,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 @@ -161,115 +369,63 @@ instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) \end{code} + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + \begin{code} -mkDataCon :: Name +mkDataCon :: Name + -> Bool -- Declared infix + -> Bool -- Vanilla (see notes with dcVanilla) -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType - -> [TauType] -> TyCon - -> Id + -> [TyVar] -> ThetaType -> ThetaType + -> [Type] -> TyCon -> [Type] + -> DataConIds -> DataCon -- Can get the tag from the TyCon -mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon id - = ASSERT(length arg_stricts == length 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 +mkDataCon name declared_infix vanilla + arg_stricts -- Must match orig_arg_tys 1-1 + fields + tyvars stupid_theta theta orig_arg_tys tycon res_tys + ids + = con where - con = MkData {dcName = name, dcUnique = nameUnique name, - dcTyVars = tyvars, dcTheta = theta, - dcOrigArgTys = orig_arg_tys, + con = MkData {dcName = name, + dcUnique = nameUnique name, dcVanilla = vanilla, + dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta, + dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys, dcRepArgTys = rep_arg_tys, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcRealStricts = all_stricts, dcUserStricts = user_stricts, - dcFields = fields, dcTag = tag, dcTyCon = tycon, dcType = ty, - dcId = id} - - (real_arg_stricts, strict_arg_tyss) - = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys) - rep_arg_tys = concat strict_arg_tyss + dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = ty, + dcIds = ids, dcInfix = declared_infix} + + -- Strictness marks for source-args + -- *after unboxing choices*, + -- but *including existential dictionaries* + -- + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + dict_tys = mkPredTys theta + real_arg_tys = dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark theta ++ arg_stricts - all_stricts = (map mk_dict_strict_mark ex_theta) ++ real_arg_stricts - user_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts - -- Add a strictness flag for the existential dictionary arguments + -- 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 rep_arg_tys - (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 - --- 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. - -unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type]) -unbox_strict_arg_ty tycon NotMarkedStrict ty - = (NotMarkedStrict, [ty]) -unbox_strict_arg_ty tycon MarkedStrict ty - | not opt_UnboxStrictFields - || not (isLocallyDefinedName (getName tycon)) = (MarkedStrict, [ty]) -unbox_strict_arg_ty tycon marked_unboxed ty - -- MarkedUnboxed || (MarkedStrict && opt_UnboxStrictFields && not imported) - = case splitAlgTyConApp_maybe ty of - Just (tycon,_,[]) - -> panic (showSDoc (hcat [ - text "unbox_strict_arg_ty: constructors for ", - ppr tycon, - text " not available." - ])) - Just (tycon,ty_args,[con]) - -> case maybe_unpack_fields emptyUniqSet - (zip (dataConOrigArgTys con ty_args) - (dcUserStricts con)) - of - Nothing -> (MarkedStrict, [ty]) - Just tys -> (MarkedUnboxed con tys, tys) - _ -> (MarkedStrict, [ty]) - --- bail out if we encounter the same tycon twice. This avoids problems like --- --- data A = !B --- data B = !A --- --- where no useful unpacking can be done. - -maybe_unpack_field :: UniqSet TyCon -> Type -> StrictnessMark -> Maybe [Type] -maybe_unpack_field set ty NotMarkedStrict - = Just [ty] -maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields - = Just [ty] -maybe_unpack_field set ty strict - = case splitAlgTyConApp_maybe ty of - Just (tycon,ty_args,[con]) - | tycon `elementOfUniqSet` set -> Nothing - | otherwise -> - let set' = addOneToUniqSet set tycon in - maybe_unpack_fields set' - (zip (dataConOrigArgTys con ty_args) - (dcUserStricts con)) - _ -> Just [ty] - -maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type] -maybe_unpack_fields set tys - | all isJust unpacked_fields = Just (concat (catMaybes unpacked_fields)) - | otherwise = Nothing - where unpacked_fields = map (\(ty,str) -> maybe_unpack_field set ty str) tys -\end{code} + ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty) + -- NB: the existential dict args are already in rep_arg_tys + + result_ty = mkTyConApp tycon res_tys +mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict + | otherwise = NotMarkedStrict +\end{code} \begin{code} dataConName :: DataCon -> Name @@ -281,76 +437,196 @@ dataConTag = dcTag dataConTyCon :: DataCon -> TyCon dataConTyCon = dcTyCon -dataConType :: DataCon -> Type -dataConType = dcType +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +dataConTyVars :: DataCon -> [TyVar] +dataConTyVars = dcTyVars -dataConId :: DataCon -> Id -dataConId = dcId +dataConWorkId :: DataCon -> Id +dataConWorkId dc = case dcIds dc of + AlgDC _ wrk_id -> wrk_id + NewDC _ -> pprPanic "dataConWorkId" (ppr dc) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcIds dc of + AlgDC mb_wrap _ -> mb_wrap + NewDC wrap -> Just wrap + +dataConWrapId :: DataCon -> Id +-- Returns an Id which looks like the Haskell-source constructor +dataConWrapId dc = case dcIds dc of + AlgDC (Just wrap) _ -> wrap + AlgDC Nothing wrk -> wrk -- worker=wrapper + NewDC wrap -> wrap + +dataConImplicitIds :: DataCon -> [Id] +dataConImplicitIds dc = case dcIds dc of + AlgDC (Just wrap) work -> [wrap,work] + AlgDC Nothing work -> [work] + NewDC wrap -> [wrap] dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields +dataConFieldType :: DataCon -> FieldLabel -> Type +dataConFieldType con label = expectJust "unexpected label" $ + lookup label (dcFields con `zip` dcOrigArgTys con) + dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks = dcRealStricts +dataConStrictMarks = dcStrictMarks -dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience -dataConRawArgTys = dcRepArgTys +dataConExStricts :: DataCon -> [StrictnessMark] +-- Strictness of *existential* arguments only +-- Usually empty, so we don't bother to cache this +dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc) dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor dataConSourceArity dc = length (dcOrigArgTys dc) -dataConSig :: DataCon -> ([TyVar], ThetaType, - [TyVar], ThetaType, - [TauType], TyCon) +-- 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 -dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) +isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = null (dcOrigArgTys dc) +isNullaryRepDataCon dc = null (dcRepArgTys dc) -dataConArgTys, dataConOrigArgTys :: DataCon - -> [Type] -- Instantiated at these types - -- NB: these INCLUDE the existentially quantified arg types - -> [Type] -- Needs arguments of these types +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, + [Type], TyCon, [Type]) + +dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, + dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys}) + = (tyvars, theta, arg_tys, tycon, res_tys) + +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConResTys :: DataCon -> [Type] +dataConResTys dc = dcResTys dc + +dataConInstArgTys :: 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 +dataConInstArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + +dataConInstResTy :: DataCon -> [Type] -> Type +dataConInstResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + substTy (zipOpenTvSubst tyvars inst_tys) (mkTyConApp tc res_tys) + -- res_tys can't currently contain any foralls, + -- but might in future; hence zipOpenTvSubst + +-- And the same deal for the original arg tys +dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys +\end{code} -dataConArgTys (MkData {dcRepArgTys = 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) +These two functions get the real argument types of the constructor, +without substituting for any type variables. -dataConOrigArgTys (MkData {dcOrigArgTys = 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) -\end{code} +dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args. -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 +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, dcRepArgTys = 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 isUnboxedTupleCon :: DataCon -> Bool isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc -isExistentialDataCon :: DataCon -> Bool -isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs) +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc +\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, dataConInstArgTys 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) + + +computeRep :: [StrictnessMark] -- Original arg strictness + -> [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" ty \end{code}