X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FbasicTypes%2FDataCon.lhs;h=38185801a0669c35bedfff9090178f4491741aad;hb=fe548aebdad3520e51d92fcda6bec9d26d69aa4a;hp=195c192747b5f0b737c55eae8a39603342547309;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 195c192..3818580 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -10,59 +10,152 @@ module DataCon ( mkDataCon, dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys, - dataConRepArgTys, dataConTheta, + dataConRepArgTys, dataConTheta, dataConFieldLabels, dataConStrictMarks, dataConSourceArity, dataConRepArity, - dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness, + dataConNumInstArgs, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon, classDataCon, + isExistentialDataCon, classDataCon, dataConExistentialTyVars, splitProductType_maybe, splitProductType, ) where #include "HsVersions.h" -import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) +import {-# SOURCE #-} Subst( substTyWith ) +import {-# SOURCE #-} PprType( pprType ) -import CmdLineOpts ( opt_DictsStrict ) -import Type ( Type, TauType, ThetaType, +import Type ( Type, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, splitTyConApp_maybe, repType + mkTyVarTys, splitTyConApp_maybe, repType, + mkPredTys, isStrictType ) -import TcType ( isStrictPred, mkPredTys ) -import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon, +import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) -import BasicTypes ( Arity ) -import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy ) +import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) -import PprType () -- Instances -import Maybe +import Maybes ( orElse ) import ListSetOps ( assoc ) -import Util ( zipEqual, zipWithEqual ) +import Util ( zipEqual, zipWithEqual, notNull ) \end{code} -Stuff about data constructors -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every constructor, C, comes with a +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration - *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 + 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 ... } - *worker*, called $wC, which is the actual data constructor. - Its type may be different to C, because: +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 - It does not have a binding. + The worker is very like a primop, in that it has no binding. + + Newtypes currently do get a worker-Id, but it is never used. + + + 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 worker is very like a primop, in that it has no binding, + 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.] @@ -76,7 +169,8 @@ Every constructor, C, comes with a data DataCon = MkData { -- Used for data constructors only; -- there *is* no constructor for a newtype - dcName :: Name, + dcName :: Name, + dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, @@ -85,9 +179,18 @@ data DataCon -- 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: + -- 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. @@ -99,11 +202,23 @@ data DataCon -- dcOrigArgTys = [a,List b] -- dcTyCon = T - dcTyVars :: [TyVar], -- Type vars and context for the data type decl + 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 :: ThetaType, + + 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 dcWrapId, 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 @@ -115,7 +230,7 @@ data DataCon dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, -- and including existential dictionaries - dcRepStrictness :: [Demand], -- One for each representation argument + dcRepStrictness :: [StrictnessMark], -- One for each representation argument dcTyCon :: TyCon, -- Result tycon @@ -138,10 +253,13 @@ data DataCon -- -- 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 + -- Perhaps this should be a 'Maybe'; not reqd for newtype constructors - dcWrapId :: Id -- The wrapper Id + dcWrapId :: Maybe Id -- The wrapper Id, if it's necessary + -- It's deemed unnecessary if it performs the + -- identity function } type ConTag = Int @@ -201,51 +319,53 @@ instance Show DataCon where %************************************************************************ %* * -\subsection{Consruction} +\subsection{Construction} %* * %************************************************************************ \begin{code} -mkDataCon :: Name +mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType - -> [TauType] -> TyCon - -> Id -> Id + -> [Type] -> TyCon + -> Id -> Maybe Id -- Worker and possible wrapper -> DataCon -- Can get the tag from the TyCon -mkDataCon name arg_stricts fields +mkDataCon name + arg_stricts -- Use [] to mean 'all non-strict' + 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 - -- source-language arguments. We add extra ones for the - -- dictionary arguments right here. - con + = con where - con = MkData {dcName = name, dcUnique = nameUnique name, - dcTyVars = tyvars, dcTheta = theta, + con = MkData {dcName = name, + dcUnique = nameUnique name, + dcTyVars = tyvars, dcStupidTheta = theta, dcOrigArgTys = orig_arg_tys, dcRepArgTys = rep_arg_tys, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands, + 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} -- Strictness marks for source-args -- *after unboxing choices*, -- but *including existential dictionaries* - real_stricts = (map mk_dict_strict_mark ex_theta) ++ - zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) - orig_arg_tys arg_stricts + -- + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + ex_dict_tys = mkPredTys ex_theta + real_stricts = map mk_dict_strict_mark ex_dict_tys ++ + zipWith (chooseBoxingStrategy tycon) + orig_arg_tys + (arg_stricts ++ repeat NotMarkedStrict) + real_arg_tys = ex_dict_tys ++ orig_arg_tys -- Representation arguments and demands - (rep_arg_demands, rep_arg_tys) - = unzip $ concat $ - zipWithEqual "mkDataCon2" unbox_strict_arg_ty - real_stricts - (mkPredTys ex_theta ++ orig_arg_tys) + (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) @@ -254,8 +374,8 @@ mkDataCon name arg_stricts fields result_ty = mkTyConApp tycon (mkTyVarTys tyvars) -mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark ty | isStrictType ty = MarkedStrict + | otherwise = NotMarkedStrict \end{code} \begin{code} @@ -271,11 +391,17 @@ dataConTyCon = dcTyCon dataConRepType :: DataCon -> Type dataConRepType = dcRepType -dataConId :: DataCon -> Id -dataConId = dcId +dataConWorkId :: DataCon -> Id +dataConWorkId = dcWorkId + +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe = dcWrapId dataConWrapId :: DataCon -> Id -dataConWrapId = dcWrapId +-- Returns an Id which looks like the Haskell-source constructor +-- If there is no dcWrapId it's because there is no need for a +-- wrapper, so the worker is the Right Thing +dataConWrapId dc = dcWrapId dc `orElse` dcWorkId dc dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields @@ -300,16 +426,16 @@ dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys isNullaryDataCon con = dataConRepArity con == 0 -dataConRepStrictness :: DataCon -> [Demand] +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) + [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) @@ -324,17 +450,20 @@ dataConArgTys :: DataCon 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 -> ThetaType -dataConTheta dc = dcTheta dc +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 (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, @@ -349,7 +478,7 @@ after any flattening has been done. dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc -dataConRepArgTys :: DataCon -> [TauType] +dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys dc = dcRepArgTys dc \end{code} @@ -362,7 +491,7 @@ 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} @@ -403,13 +532,13 @@ splitProductType_maybe ty -- 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 @@ -442,16 +571,18 @@ chooseBoxingStrategy tycon arg_ty strict Nothing -> False Just (arg_tycon, _) -> isProductTyCon arg_tycon -unbox_strict_arg_ty - :: StrictnessMark -- After strategy choice; can't be MkaredUserStrict - -> Type -- Source argument type - -> [(Demand,Type)] -- Representation argument types and demamds +computeRep :: [StrictnessMark] -- Original arg strictness + -- [after strategy choice; can't be MarkedUserStrict] + -> [Type] -- and types + -> ([StrictnessMark], -- Representation arg strictness + [Type]) -- And type -unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy, ty)] -unbox_strict_arg_ty MarkedStrict ty = [(wwStrict, ty)] -unbox_strict_arg_ty MarkedUnboxed ty - = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys +computeRep stricts tys + = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys where - (_, _, arg_data_con, arg_tys) - = splitProductType "unbox_strict_arg_ty" (repType ty) + 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}