X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=dbc63552045b56f1d8182c09ea49bcc4e16bfa11;hb=474b582b68ea9289f3da4355da816164138604b0;hp=5211fc8eba9574b8b4d280064ce08d43675870e4;hpb=3c8e76dc677b4b427c7696f0f563224b548bf43b;p=ghc-hetmet.git diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 5211fc8..dbc6355 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -11,9 +11,9 @@ module DataCon ( mkDataCon, dataConRepType, dataConSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType, - dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, + dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, @@ -43,6 +43,11 @@ import ListSetOps import Util import Maybes import FastString +import PackageConfig +import Module + +import Data.Char +import Data.Word \end{code} @@ -233,7 +238,7 @@ data DataCon -- dcEqSpec = [a:=:(x,y)] -- dcTheta = [Ord x] -- dcOrigArgTys = [a,List b] - -- dcTyCon = T + -- dcRepTyCon = T dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor -- Its type is of form @@ -246,6 +251,8 @@ data DataCon -- 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 @@ -288,9 +295,11 @@ data DataCon dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of strict fields) - - -- Result type of constructor is T t1..tn - dcTyCon :: TyCon, -- Result tycon, T + dcOrigResTy :: Type, -- Original result type + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- Now the strictness annotations and field labels of the constructor dcStrictMarks :: [StrictnessMark], @@ -300,7 +309,7 @@ data DataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the - -- same order as the argument types; + -- same order as the dcOrigArgTys; -- length = 0 (if not a record) or dataConSourceArity. -- Constructor representation @@ -311,6 +320,9 @@ data DataCon dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument -- See also Note [Data-con worker strictness] in MkId.lhs + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + dcRepType :: Type, -- Type of the constructor -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a -- (this is *not* of the constructor wrapper Id: @@ -459,7 +471,8 @@ mkDataCon name declared_infix dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcStupidTheta = stupid_theta, dcTheta = theta, - dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = tycon, dcRepArgTys = rep_arg_tys, dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, @@ -477,6 +490,15 @@ mkDataCon name declared_infix real_arg_tys = dict_tys ++ orig_arg_tys real_stricts = map mk_dict_strict_mark theta ++ arg_stricts + -- Example + -- data instance T (b,c) where + -- TI :: forall e. e -> T (e,e) + -- + -- The representation tycon looks like this: + -- data :R7T b c where + -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 + orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tvs) + -- Representation arguments and demands -- To do: eliminate duplication with MkId (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys @@ -501,24 +523,11 @@ 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 dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcTyCon +dataConTyCon = dcRepTyCon dataConRepType :: DataCon -> Type dataConRepType = dcRepType @@ -597,74 +606,71 @@ dataConRepStrictness :: DataCon -> [StrictnessMark] -- Core constructor application (Con dc args) dataConRepStrictness dc = dcRepStrictness dc -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type]) +dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys) + dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type]) + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) + dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta dc = dcStupidTheta dc -dataConResTys :: DataCon -> [Type] -dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc] - where - env = mkTopTvSubst (dcEqSpec 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, - dcTyCon = tycon }) + dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - case tyConFamInst_maybe tycon of - Nothing -> mkTyConApp tycon (substTyVars subst univ_tvs) - Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance - where - subst = mkTopTvSubst eq_spec + 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 \end{code} These two functions get the real argument types of the constructor, @@ -683,13 +689,26 @@ 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 -isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc +isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc @@ -700,6 +719,7 @@ isVanillaDataCon dc = dcVanilla dc classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" \end{code} %************************************************************************ @@ -733,7 +753,8 @@ splitProductType_maybe ty -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) where - data_con = head (tyConDataCons tycon) + data_con = ASSERT( not (null (tyConDataCons tycon)) ) + head (tyConDataCons tycon) other -> Nothing splitProductType str ty @@ -745,8 +766,9 @@ splitProductType str ty 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}