X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=0c6e3c57200d8f94c9e6d1691100b38af8875de3;hp=ee2c6857dc24f4f7d0cfcf78db6784afb3958f2e;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=70918cf4a4d61d4752b18f29ce14c7d7f1fbce01 diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index ee2c685..0c6e3c5 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -12,9 +12,10 @@ module DataCon ( dataConRepType, dataConSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, - dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, + dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, + dataConInstOrigArgTys, dataConInstOrigDictsAndArgTys, + dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, dataConSourceArity, dataConRepArity, @@ -43,6 +44,11 @@ import ListSetOps import Util import Maybes import FastString +import Module + +import Data.Char +import Data.Word +import Data.List ( partition ) \end{code} @@ -81,15 +87,20 @@ differently, as follows. Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly three, Names associated with it: +Each data constructor C has two, and possibly up to four, Names associated with it: - OccName Name space Used for + OccName Name space Name of --------------------------------------------------------------------------- - * 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 + * The "data con itself" C DataName DataCon + * The "worker data con" C VarName Id (the worker) + * The "wrapper data con" $WC VarName Id (the wrapper) + * The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" 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). @@ -123,6 +134,8 @@ The "wrapper Id", $WC, goes as follows nothing for the wrapper to do. That is, if its defn would be $wC = C +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why might the wrapper have anything to do? Two reasons: * Unboxing strict fields (with -funbox-strict-fields) @@ -146,6 +159,8 @@ Why might the wrapper have anything to do? Two reasons: The third argument is a coerion [a] :: [a]:=:[a] +INVARIANT: the dictionary constructor for a class + never has a wrapper. A note about the stupid context @@ -219,11 +234,11 @@ data DataCon -- -- *** As declared by the user -- data T a where - -- MkT :: forall x y. (Ord x) => x -> y -> T (x,y) + -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) -- *** As represented internally -- data T a where - -- MkT :: forall a. forall x y. (a:=:(x,y), Ord x) => x -> y -> T a + -- MkT :: forall a. forall x y. (a:=:(x,y),x~y,Ord x) => x -> y -> T a -- -- The next six fields express the type of the constructor, in pieces -- e.g. @@ -231,7 +246,8 @@ data DataCon -- dcUnivTyVars = [a] -- dcExTyVars = [x,y] -- dcEqSpec = [a:=:(x,y)] - -- dcTheta = [Ord x] + -- dcEqTheta = [x~y] + -- dcDictTheta = [Ord x] -- dcOrigArgTys = [a,List b] -- dcRepTyCon = T @@ -239,13 +255,15 @@ data DataCon -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcTheta = [] + -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) dcUnivTyVars :: [TyVar], -- Universally-quantified type vars + -- INVARIANT: length matches arity of the dcRepTyCon + dcExTyVars :: [TyVar], -- Existentially-quantified type vars -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS -- FOR THE PARENT TyCon. With GADTs the data con might not even have @@ -265,11 +283,14 @@ data DataCon -- Each equality is of the form (a :=: ty), where 'a' is one of -- the universally quantified type variables - dcTheta :: ThetaType, -- The context of the constructor + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) -- In GADT form, this is *exactly* what the programmer writes, even if -- the context constrains only universally quantified variables - -- MkT :: forall a. Eq a => a -> T a - -- It may contain user-written equality predicates too + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcEqTheta :: ThetaType, -- The *equational* constraints + dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints dcStupidTheta :: ThetaType, -- The context of the data type declaration -- data Eq a => T a = ... @@ -453,7 +474,7 @@ mkDataCon name declared_infix -- so the error is detected properly... it's just that asaertions here -- are a little dodgy. - = ASSERT( not (any isEqPred theta) ) + = -- ASSERT( not (any isEqPred theta) ) -- We don't currently allow any equality predicates on -- a data constructor (apart from the GADT ones in eq_spec) con @@ -463,7 +484,8 @@ mkDataCon name declared_infix dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcStupidTheta = stupid_theta, dcTheta = theta, + dcStupidTheta = stupid_theta, + dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = tycon, dcRepArgTys = rep_arg_tys, @@ -479,25 +501,20 @@ mkDataCon name declared_infix -- 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 + (eq_theta,dict_theta) = partition isEqPred theta + dict_tys = mkPredTys dict_theta + real_arg_tys = dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts -- Example - -- data instance T [a] where - -- TI :: forall b. b -> T [Maybe b] + -- data instance T (b,c) where + -- TI :: forall e. e -> T (e,e) + -- -- The representation tycon looks like this: - -- data :R7T a where - -- TI :: forall b c. (c :=: Maybe b) b -> :R7T c - orig_res_ty - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tycon - , let fam_subst = zipTopTvSubst (tyConTyVars fam_tc) res_tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tycon res_tys - where - res_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs - -- In the example above, res_tys is a singleton, (Maybe b) + -- data :R7T b c where + -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 + -- In this case orig_res_ty = T (e,e) + orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tvs) -- Representation arguments and demands -- To do: eliminate duplication with MkId @@ -506,6 +523,7 @@ mkDataCon name declared_infix tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $ + mkFunTys (mkPredTys eq_theta) $ -- NB: the dict args are already in rep_arg_tys -- because they might be flattened.. -- but the equality predicates are not @@ -515,6 +533,7 @@ mkDataCon name declared_infix eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] +mk_dict_strict_mark :: PredType -> StrictnessMark mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict | otherwise = NotMarkedStrict \end{code} @@ -523,19 +542,6 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict dataConName :: DataCon -> Name dataConName = dcName --- generate a name in the format: package:Module.OccName --- and the unique identity of the name -dataConIdentity :: DataCon -> String -dataConIdentity dataCon - = prettyName - where - prettyName = pretty packageModule ++ "." ++ pretty occ - nm = getName dataCon - packageModule = nameModule nm - occ = getOccName dataCon - pretty :: Outputable a => a -> String - pretty = showSDoc . ppr - dataConTag :: DataCon -> ConTag dataConTag = dcTag @@ -561,8 +567,11 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) dataConEqSpec :: DataCon -> [(TyVar,Type)] dataConEqSpec = dcEqSpec -dataConTheta :: DataCon -> ThetaType -dataConTheta = dcTheta +dataConEqTheta :: DataCon -> ThetaType +dataConEqTheta = dcEqTheta + +dataConDictTheta :: DataCon -> ThetaType +dataConDictTheta = dcDictTheta dataConWorkId :: DataCon -> Id dataConWorkId dc = case dcIds dc of @@ -598,7 +607,7 @@ dataConStrictMarks = dcStrictMarks 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) +dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor @@ -608,6 +617,7 @@ dataConSourceArity dc = length (dcOrigArgTys dc) -- {\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 :: DataCon -> Int dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool @@ -621,14 +631,14 @@ dataConRepStrictness dc = dcRepStrictness dc dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) + dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty) dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -639,48 +649,67 @@ dataConStupidTheta dc = dcStupidTheta dc dataConUserType :: DataCon -> Type -- The user-declared type of the data constructor -- in the nice-to-read form --- T :: forall a. a -> T [a] +-- T :: forall a b. a -> b -> T [a] -- rather than --- T :: forall b. forall a. (a=[b]) => a -> T b +-- T :: forall a c. forall b. (c=[a]) => a -> b -> T c -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, + dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys theta) $ + mkFunTys (mkPredTys eq_theta) $ + mkFunTys (mkPredTys dict_theta) $ mkFunTys arg_tys $ res_ty -dataConInstArgTys :: DataCon +dataConInstArgTys :: DataCon -- A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) -> [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 + -- NB: these INCLUDE any dict args -- but EXCLUDE the data-decl context which is discarded -- It's all post-flattening etc; this is a representation type -dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys, - dcUnivTyVars = univ_tvs, +dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, + dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec, dcExTyVars = ex_tvs}) inst_tys - = ASSERT2 ( length tyvars == length inst_tys - , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) - - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs - - --- And the same deal for the original arg tys -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] + = ASSERT2 ( length univ_tvs == length inst_tys + , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2 ( null ex_tvs && null eq_spec, ppr dc ) + map (substTyWith univ_tvs inst_tys) rep_arg_tys + +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] -- Returns just the instsantiated *value* arguments +-- For vanilla datacons, it's all quite straightforward +-- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length inst_tys + = ASSERT2( length tyvars == length inst_tys , ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + +dataConInstOrigDictsAndArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] -- Returns just the instsantiated dicts and *value* arguments +dataConInstOrigDictsAndArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcDictTheta = dicts, + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext SLIT("dataConInstOrigDictsAndArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) (mkPredTys dicts ++ arg_tys) + where + tyvars = univ_tvs ++ ex_tvs \end{code} These two functions get the real argument types of the constructor, @@ -699,6 +728,19 @@ dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys dc = dcRepArgTys dc \end{code} +The string :. identifying a constructor, which is attached +to its info table and used by the GHCi debugger and the heap profiler. We want +this string to be UTF-8, so we get the bytes directly from the FastStrings. + +\begin{code} +dataConIdentity :: DataCon -> [Word8] +dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ + fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ + fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) + where name = dataConName dc + mod = nameModule name +\end{code} + \begin{code} isTupleCon :: DataCon -> Bool @@ -750,26 +792,31 @@ splitProductType_maybe ty -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) where - data_con = head (tyConDataCons tycon) - other -> Nothing + data_con = ASSERT( not (null (tyConDataCons tycon)) ) + head (tyConDataCons tycon) + _other -> Nothing +splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) splitProductType str ty = case splitProductType_maybe ty of Just stuff -> stuff Nothing -> pprPanic (str ++ ": not a product") (pprType ty) +deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type]) deepSplitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty ; let {result - | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) - = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) + | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args + , not (isRecursiveTyCon tycon) + = deepSplitProductType_maybe ty' -- Ignore the coercion? | isNewTyCon tycon = Nothing -- cannot unbox through recursive -- newtypes nor through families | otherwise = Just res} ; result } +deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) deepSplitProductType str ty = case deepSplitProductType_maybe ty of Just stuff -> stuff